/[slime]/slime/swank-corman.lisp
ViewVC logotype

Contents of /slime/swank-corman.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (show annotations)
Sat Aug 4 23:48:19 2012 UTC (20 months, 2 weeks ago) by sboukarev
Branch: MAIN
CVS Tags: HEAD
Changes since 1.27: +15 -16 lines
* clean up: (signal (make-condition ...)) => (signal ...)
1 ;;;
2 ;;; swank-corman.lisp --- Corman Lisp specific code for SLIME.
3 ;;;
4 ;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org)
5 ;;;
6 ;;; License
7 ;;; =======
8 ;;; This software is provided 'as-is', without any express or implied
9 ;;; warranty. In no event will the author be held liable for any damages
10 ;;; arising from the use of this software.
11 ;;;
12 ;;; Permission is granted to anyone to use this software for any purpose,
13 ;;; including commercial applications, and to alter it and redistribute
14 ;;; it freely, subject to the following restrictions:
15 ;;;
16 ;;; 1. The origin of this software must not be misrepresented; you must
17 ;;; not claim that you wrote the original software. If you use this
18 ;;; software in a product, an acknowledgment in the product documentation
19 ;;; would be appreciated but is not required.
20 ;;;
21 ;;; 2. Altered source versions must be plainly marked as such, and must
22 ;;; not be misrepresented as being the original software.
23 ;;;
24 ;;; 3. This notice may not be removed or altered from any source
25 ;;; distribution.
26 ;;;
27 ;;; Notes
28 ;;; =====
29 ;;; You will need CCL 2.51, and you will *definitely* need to patch
30 ;;; CCL with the patches at
31 ;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME
32 ;;; will blow up in your face. You should also follow the
33 ;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime.
34 ;;;
35 ;;; The only communication style currently supported is NIL.
36 ;;;
37 ;;; Starting CCL inside emacs (with M-x slime) seems to work for me
38 ;;; with Corman Lisp 2.51, but I have seen random failures with 2.5
39 ;;; (sometimes it works, other times it hangs on start or hangs when
40 ;;; initializing WinSock) - starting CCL externally and using M-x
41 ;;; slime-connect always works fine.
42 ;;;
43 ;;; Sometimes CCL gets confused and starts giving you random memory
44 ;;; access violation errors on startup; if this happens, try redumping
45 ;;; your image.
46 ;;;
47 ;;; What works
48 ;;; ==========
49 ;;; * Basic editing and evaluation
50 ;;; * Arglist display
51 ;;; * Compilation
52 ;;; * Loading files
53 ;;; * apropos/describe
54 ;;; * Debugger
55 ;;; * Inspector
56 ;;;
57 ;;; TODO
58 ;;; ====
59 ;;; * More debugger functionality (missing bits: restart-frame,
60 ;;; return-from-frame, disassemble-frame, activate-stepping,
61 ;;; toggle-trace)
62 ;;; * XREF
63 ;;; * Profiling
64 ;;; * More sophisticated communication styles than NIL
65 ;;;
66
67 (in-package :swank-backend)
68
69 ;;; Pull in various needed bits
70 (require :composite-streams)
71 (require :sockets)
72 (require :winbase)
73 (require :lp)
74
75 (use-package :gs)
76
77 ;; MOP stuff
78
79 (defclass swank-mop:standard-slot-definition ()
80 ()
81 (:documentation
82 "Dummy class created so that swank.lisp will compile and load."))
83
84 (defun named-by-gensym-p (c)
85 (null (symbol-package (class-name c))))
86
87 (deftype swank-mop:eql-specializer ()
88 '(satisfies named-by-gensym-p))
89
90 (defun swank-mop:eql-specializer-object (specializer)
91 (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*)
92 (loop (multiple-value-bind (more key value)
93 (next-entry)
94 (unless more (return nil))
95 (when (eq specializer value)
96 (return key))))))
97
98 (defun swank-mop:class-finalized-p (class)
99 (declare (ignore class))
100 t)
101
102 (defun swank-mop:class-prototype (class)
103 (make-instance class))
104
105 (defun swank-mop:specializer-direct-methods (obj)
106 (declare (ignore obj))
107 nil)
108
109 (defun swank-mop:generic-function-argument-precedence-order (gf)
110 (generic-function-lambda-list gf))
111
112 (defun swank-mop:generic-function-method-combination (gf)
113 (declare (ignore gf))
114 :standard)
115
116 (defun swank-mop:generic-function-declarations (gf)
117 (declare (ignore gf))
118 nil)
119
120 (defun swank-mop:slot-definition-documentation (slot)
121 (declare (ignore slot))
122 (getf slot :documentation nil))
123
124 (defun swank-mop:slot-definition-type (slot)
125 (declare (ignore slot))
126 t)
127
128 (import-swank-mop-symbols :cl '(;; classes
129 :standard-slot-definition
130 :eql-specializer
131 :eql-specializer-object
132 ;; standard class readers
133 :class-default-initargs
134 :class-direct-default-initargs
135 :class-finalized-p
136 :class-prototype
137 :specializer-direct-methods
138 ;; gf readers
139 :generic-function-argument-precedence-order
140 :generic-function-declarations
141 :generic-function-method-combination
142 ;; method readers
143 ;; slot readers
144 :slot-definition-documentation
145 :slot-definition-type))
146
147 ;;;; swank implementations
148
149 ;;; Debugger
150
151 (defvar *stack-trace* nil)
152 (defvar *frame-trace* nil)
153
154 (defstruct frame
155 name function address debug-info variables)
156
157 (defimplementation call-with-debugging-environment (fn)
158 (let* ((real-stack-trace (cl::stack-trace))
159 (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace
160 :key #'car)))
161 (*frame-trace*
162 (let* ((db::*debug-level* (1+ db::*debug-level*))
163 (db::*debug-frame-pointer* (db::stash-ebp
164 (ct:create-foreign-ptr)))
165 (db::*debug-max-level* (length real-stack-trace))
166 (db::*debug-min-level* 1))
167 (cdr (member #'cl:invoke-debugger
168 (cons
169 (make-frame :function nil)
170 (loop for i from db::*debug-min-level*
171 upto db::*debug-max-level*
172 until (eq (db::get-frame-function i)
173 cl::*top-level*)
174 collect
175 (make-frame
176 :function (db::get-frame-function i)
177 :address (db::get-frame-address i))))
178 :key #'frame-function)))))
179 (funcall fn)))
180
181 (defimplementation compute-backtrace (start end)
182 (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*)))
183 collect f))
184
185 (defimplementation print-frame (frame stream)
186 (format stream "~S" frame))
187
188 (defun get-frame-debug-info (frame)
189 (or (frame-debug-info frame)
190 (setf (frame-debug-info frame)
191 (db::prepare-frame-debug-info (frame-function frame)
192 (frame-address frame)))))
193
194 (defimplementation frame-locals (frame-number)
195 (let* ((frame (elt *frame-trace* frame-number))
196 (info (get-frame-debug-info frame)))
197 (let ((var-list
198 (loop for i from 4 below (length info) by 2
199 collect `(list :name ',(svref info i) :id 0
200 :value (db::debug-filter ,(svref info i))))))
201 (let ((vars (eval-in-frame `(list ,@var-list) frame-number)))
202 (setf (frame-variables frame) vars)))))
203
204 (defimplementation eval-in-frame (form frame-number)
205 (let ((frame (elt *frame-trace* frame-number)))
206 (let ((cl::*compiler-environment* (get-frame-debug-info frame)))
207 (eval form))))
208
209 (defimplementation frame-var-value (frame-number var)
210 (let ((vars (frame-variables (elt *frame-trace* frame-number))))
211 (when vars
212 (second (elt vars var)))))
213
214 (defimplementation frame-source-location (frame-number)
215 (fspec-location (frame-function (elt *frame-trace* frame-number))))
216
217 (defun break (&optional (format-control "Break") &rest format-arguments)
218 (with-simple-restart (continue "Return from BREAK.")
219 (let ();(*debugger-hook* nil))
220 (let ((condition
221 (make-condition 'simple-condition
222 :format-control format-control
223 :format-arguments format-arguments)))
224 ;;(format *debug-io* ";;; User break: ~A~%" condition)
225 (invoke-debugger condition))))
226 nil)
227
228 ;;; Socket communication
229
230 (defimplementation create-socket (host port &key backlog)
231 (sockets:start-sockets)
232 (sockets:make-server-socket :host host :port port))
233
234 (defimplementation local-port (socket)
235 (sockets:socket-port socket))
236
237 (defimplementation close-socket (socket)
238 (close socket))
239
240 (defimplementation accept-connection (socket
241 &key external-format buffering timeout)
242 (declare (ignore buffering timeout external-format))
243 (sockets:make-socket-stream (sockets:accept-socket socket)))
244
245 ;;; Misc
246
247 (defimplementation preferred-communication-style ()
248 nil)
249
250 (defimplementation getpid ()
251 ccl:*current-process-id*)
252
253 (defimplementation lisp-implementation-type-name ()
254 "cormanlisp")
255
256 (defimplementation quit-lisp ()
257 (sockets:stop-sockets)
258 (win32:exitprocess 0))
259
260 (defimplementation set-default-directory (directory)
261 (setf (ccl:current-directory) directory)
262 (directory-namestring (setf *default-pathname-defaults*
263 (truename (merge-pathnames directory)))))
264
265 (defimplementation default-directory ()
266 (directory-namestring (ccl:current-directory)))
267
268 (defimplementation macroexpand-all (form)
269 (ccl:macroexpand-all form))
270
271 ;;; Documentation
272
273 (defun fspec-location (fspec)
274 (when (symbolp fspec)
275 (setq fspec (symbol-function fspec)))
276 (let ((file (ccl::function-source-file fspec)))
277 (if file
278 (handler-case
279 (let ((truename (truename
280 (merge-pathnames file
281 ccl:*cormanlisp-directory*))))
282 (make-location (list :file (namestring truename))
283 (if (ccl::function-source-line fspec)
284 (list :line
285 (1+ (ccl::function-source-line fspec)))
286 (list :function-name
287 (princ-to-string
288 (function-name fspec))))))
289 (error (c) (list :error (princ-to-string c))))
290 (list :error (format nil "No source information available for ~S"
291 fspec)))))
292
293 (defimplementation find-definitions (name)
294 (list (list name (fspec-location name))))
295
296 (defimplementation arglist (name)
297 (handler-case
298 (cond ((and (symbolp name)
299 (macro-function name))
300 (ccl::macro-lambda-list (symbol-function name)))
301 (t
302 (when (symbolp name)
303 (setq name (symbol-function name)))
304 (if (eq (class-of name) cl::the-class-standard-gf)
305 (generic-function-lambda-list name)
306 (ccl:function-lambda-list name))))
307 (error () :not-available)))
308
309 (defimplementation function-name (fn)
310 (handler-case (getf (cl::function-info-list fn) 'cl::function-name)
311 (error () nil)))
312
313 (defimplementation describe-symbol-for-emacs (symbol)
314 (let ((result '()))
315 (flet ((doc (kind &optional (sym symbol))
316 (or (documentation sym kind) :not-documented))
317 (maybe-push (property value)
318 (when value
319 (setf result (list* property value result)))))
320 (maybe-push
321 :variable (when (boundp symbol)
322 (doc 'variable)))
323 (maybe-push
324 :function (if (fboundp symbol)
325 (doc 'function)))
326 (maybe-push
327 :class (if (find-class symbol nil)
328 (doc 'class)))
329 result)))
330
331 (defimplementation describe-definition (symbol namespace)
332 (ecase namespace
333 (:variable
334 (describe symbol))
335 ((:function :generic-function)
336 (describe (symbol-function symbol)))
337 (:class
338 (describe (find-class symbol)))))
339
340 ;;; Compiler
341
342 (defvar *buffer-name* nil)
343 (defvar *buffer-position*)
344 (defvar *buffer-string*)
345 (defvar *compile-filename* nil)
346
347 ;; FIXME
348 (defimplementation call-with-compilation-hooks (FN)
349 (handler-bind ((error (lambda (c)
350 (signal 'compiler-condition
351 :original-condition c
352 :severity :warning
353 :message (format nil "~A" c)
354 :location
355 (cond (*buffer-name*
356 (make-location
357 (list :buffer *buffer-name*)
358 (list :offset *buffer-position* 0)))
359 (*compile-filename*
360 (make-location
361 (list :file *compile-filename*)
362 (list :position 1)))
363 (t
364 (list :error "No location")))))))
365 (funcall fn)))
366
367 (defimplementation swank-compile-file (input-file output-file
368 load-p external-format
369 &key policy)
370 (declare (ignore external-format policy))
371 (with-compilation-hooks ()
372 (let ((*buffer-name* nil)
373 (*compile-filename* input-file))
374 (multiple-value-bind (output-file warnings? failure?)
375 (compile-file input-file :output-file output-file)
376 (values output-file warnings?
377 (or failure? (and load-p (load output-file))))))))
378
379 (defimplementation swank-compile-string (string &key buffer position filename
380 policy)
381 (declare (ignore filename policy))
382 (with-compilation-hooks ()
383 (let ((*buffer-name* buffer)
384 (*buffer-position* position)
385 (*buffer-string* string))
386 (funcall (compile nil (read-from-string
387 (format nil "(~S () ~A)" 'lambda string))))
388 t)))
389
390 ;;;; Inspecting
391
392 ;; Hack to make swank.lisp load, at least
393 (defclass file-stream ())
394
395 (defun comma-separated (list &optional (callback (lambda (v)
396 `(:value ,v))))
397 (butlast (loop for e in list
398 collect (funcall callback e)
399 collect ", ")))
400
401 (defmethod emacs-inspect ((class standard-class))
402 `("Name: "
403 (:value ,(class-name class))
404 (:newline)
405 "Super classes: "
406 ,@(comma-separated (swank-mop:class-direct-superclasses class))
407 (:newline)
408 "Direct Slots: "
409 ,@(comma-separated
410 (swank-mop:class-direct-slots class)
411 (lambda (slot)
412 `(:value ,slot
413 ,(princ-to-string
414 (swank-mop:slot-definition-name slot)))))
415 (:newline)
416 "Effective Slots: "
417 ,@(if (swank-mop:class-finalized-p class)
418 (comma-separated
419 (swank-mop:class-slots class)
420 (lambda (slot)
421 `(:value ,slot ,(princ-to-string
422 (swank-mop:slot-definition-name slot)))))
423 '("#<N/A (class not finalized)>"))
424 (:newline)
425 ,@(when (documentation class t)
426 `("Documentation:" (:newline) ,(documentation class t) (:newline)))
427 "Sub classes: "
428 ,@(comma-separated (swank-mop:class-direct-subclasses class)
429 (lambda (sub)
430 `(:value ,sub ,(princ-to-string (class-name sub)))))
431 (:newline)
432 "Precedence List: "
433 ,@(if (swank-mop:class-finalized-p class)
434 (comma-separated
435 (swank-mop:class-precedence-list class)
436 (lambda (class)
437 `(:value ,class
438 ,(princ-to-string (class-name class)))))
439 '("#<N/A (class not finalized)>"))
440 (:newline)))
441
442 (defmethod emacs-inspect ((slot cons))
443 ;; Inspects slot definitions
444 (if (eq (car slot) :name)
445 `("Name: " (:value ,(swank-mop:slot-definition-name slot))
446 (:newline)
447 ,@(when (swank-mop:slot-definition-documentation slot)
448 `("Documentation:"
449 (:newline)
450 (:value
451 ,(swank-mop:slot-definition-documentation slot))
452 (:newline)))
453 "Init args: " (:value
454 ,(swank-mop:slot-definition-initargs slot))
455 (:newline)
456 "Init form: "
457 ,(if (swank-mop:slot-definition-initfunction slot)
458 `(:value ,(swank-mop:slot-definition-initform slot))
459 "#<unspecified>") (:newline)
460 "Init function: "
461 (:value ,(swank-mop:slot-definition-initfunction slot))
462 (:newline))
463 (call-next-method)))
464
465 (defmethod emacs-inspect ((pathname pathnames::pathname-internal))
466 (list* (if (wild-pathname-p pathname)
467 "A wild pathname."
468 "A pathname.")
469 '(:newline)
470 (append (label-value-line*
471 ("Namestring" (namestring pathname))
472 ("Host" (pathname-host pathname))
473 ("Device" (pathname-device pathname))
474 ("Directory" (pathname-directory pathname))
475 ("Name" (pathname-name pathname))
476 ("Type" (pathname-type pathname))
477 ("Version" (pathname-version pathname)))
478 (unless (or (wild-pathname-p pathname)
479 (not (probe-file pathname)))
480 (label-value-line "Truename" (truename pathname))))))
481
482 (defmethod emacs-inspect ((o t))
483 (cond ((cl::structurep o) (inspect-structure o))
484 (t (call-next-method))))
485
486 (defun inspect-structure (o)
487 (let* ((template (cl::uref o 1))
488 (num-slots (cl::struct-template-num-slots template)))
489 (cond ((symbolp template)
490 (loop for i below num-slots
491 append (label-value-line i (cl::uref o (+ 2 i)))))
492 (t
493 (loop for i below num-slots
494 append (label-value-line (elt template (+ 6 (* i 5)))
495 (cl::uref o (+ 2 i))))))))
496
497
498 ;;; Threads
499
500 (require 'threads)
501
502 (defstruct (mailbox (:conc-name mailbox.))
503 thread
504 (lock (make-instance 'threads:critical-section))
505 (queue '() :type list))
506
507 (defvar *mailbox-lock* (make-instance 'threads:critical-section))
508 (defvar *mailboxes* (list))
509
510 (defmacro with-lock (lock &body body)
511 `(threads:with-synchronization (threads:cs ,lock)
512 ,@body))
513
514 (defimplementation spawn (fun &key name)
515 (declare (ignore name))
516 (th:create-thread
517 (lambda ()
518 (handler-bind ((serious-condition #'invoke-debugger))
519 (unwind-protect (funcall fun)
520 (with-lock *mailbox-lock*
521 (setq *mailboxes* (remove cormanlisp:*current-thread-id*
522 *mailboxes* :key #'mailbox.thread))))))))
523
524 (defimplementation thread-id (thread)
525 thread)
526
527 (defimplementation find-thread (thread)
528 (if (thread-alive-p thread)
529 thread))
530
531 (defimplementation thread-alive-p (thread)
532 (if (threads:thread-handle thread) t nil))
533
534 (defimplementation current-thread ()
535 cormanlisp:*current-thread-id*)
536
537 ;; XXX implement it
538 (defimplementation all-threads ()
539 '())
540
541 ;; XXX something here is broken
542 (defimplementation kill-thread (thread)
543 (threads:terminate-thread thread 'killed))
544
545 (defun mailbox (thread)
546 (with-lock *mailbox-lock*
547 (or (find thread *mailboxes* :key #'mailbox.thread)
548 (let ((mb (make-mailbox :thread thread)))
549 (push mb *mailboxes*)
550 mb))))
551
552 (defimplementation send (thread message)
553 (let ((mbox (mailbox thread)))
554 (with-lock (mailbox.lock mbox)
555 (setf (mailbox.queue mbox)
556 (nconc (mailbox.queue mbox) (list message))))))
557
558 (defimplementation receive ()
559 (let ((mbox (mailbox cormanlisp:*current-thread-id*)))
560 (loop
561 (with-lock (mailbox.lock mbox)
562 (when (mailbox.queue mbox)
563 (return (pop (mailbox.queue mbox)))))
564 (sleep 0.1))))
565
566
567 ;;; This is probably not good, but it WFM
568 (in-package :common-lisp)
569
570 (defvar *old-documentation* #'documentation)
571 (defun documentation (thing &optional (type 'function))
572 (if (symbolp thing)
573 (funcall *old-documentation* thing type)
574 (values)))
575
576 (defmethod print-object ((restart restart) stream)
577 (if (or *print-escape*
578 *print-readably*)
579 (print-unreadable-object (restart stream :type t :identity t)
580 (princ (restart-name restart) stream))
581 (when (functionp (restart-report-function restart))
582 (funcall (restart-report-function restart) stream))))

  ViewVC Help
Powered by ViewVC 1.1.5