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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.76 - (show annotations)
Mon Nov 2 09:20:33 2009 UTC (4 years, 5 months ago) by heller
Branch: MAIN
Changes since 1.75: +0 -3 lines
* swank.lisp (without-interrupts): Removed. No longer used.
* swank-backend.lisp (call-without-interrupts): Removed.
Update backends accoringly.
1 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
2 ;;;
3 ;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME.
4 ;;;
5 ;;; Adapted from swank-acl.lisp, Andras Simon, 2004
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties
8 ;;; are disclaimed.
9 ;;;
10
11 (in-package :swank-backend)
12
13 (eval-when (:compile-toplevel :load-toplevel :execute)
14 (require :collect) ;just so that it doesn't spoil the flying letters
15 (require :pprint))
16
17 ;;; The introduction of SYS::*INVOKE-DEBUGGER-HOOK* obliterates the
18 ;;; need for redefining BREAK. The following should thus be removed at
19 ;;; some point in the future.
20 #-#.(swank-backend::with-symbol '*invoke-debugger-hook* 'sys)
21 (defun sys::break (&optional (format-control "BREAK called")
22 &rest format-arguments)
23 (let ((sys::*saved-backtrace*
24 #+#.(swank-backend::with-symbol 'backtrace 'sys)
25 (sys:backtrace)
26 #-#.(swank-backend::with-symbol 'backtrace 'sys)
27 (ext:backtrace-as-list)
28 ))
29 (with-simple-restart (continue "Return from BREAK.")
30 (invoke-debugger
31 (sys::%make-condition 'simple-condition
32 (list :format-control format-control
33 :format-arguments format-arguments))))
34 nil))
35
36 (defimplementation make-output-stream (write-string)
37 (ext:make-slime-output-stream write-string))
38
39 (defimplementation make-input-stream (read-string)
40 (ext:make-slime-input-stream read-string
41 (make-synonym-stream '*standard-output*)))
42
43 (defimplementation call-with-compilation-hooks (function)
44 (funcall function))
45
46 ;;; swank-mop
47
48 ;;dummies and definition
49
50 (defclass standard-slot-definition ()())
51
52 ;(defun class-finalized-p (class) t)
53
54 (defun slot-definition-documentation (slot)
55 (declare (ignore slot))
56 #+nil (documentation slot 't))
57
58 (defun slot-definition-type (slot)
59 (declare (ignore slot))
60 t)
61
62 (defun class-prototype (class)
63 (declare (ignore class))
64 nil)
65
66 (defun generic-function-declarations (gf)
67 (declare (ignore gf))
68 nil)
69
70 (defun specializer-direct-methods (spec)
71 (mop::class-direct-methods spec))
72
73 (defun slot-definition-name (slot)
74 (mop::%slot-definition-name slot))
75
76 (defun class-slots (class)
77 (mop::%class-slots class))
78
79 (defun method-generic-function (method)
80 (mop::%method-generic-function method))
81
82 (defun method-function (method)
83 (mop::%method-function method))
84
85 (defun slot-boundp-using-class (class object slotdef)
86 (declare (ignore class))
87 (system::slot-boundp object (slot-definition-name slotdef)))
88
89 (defun slot-value-using-class (class object slotdef)
90 (declare (ignore class))
91 (system::slot-value object (slot-definition-name slotdef)))
92
93 (import-to-swank-mop
94 '( ;; classes
95 cl:standard-generic-function
96 standard-slot-definition ;;dummy
97 cl:method
98 cl:standard-class
99 ;; standard-class readers
100 mop::class-default-initargs
101 mop::class-direct-default-initargs
102 mop::class-direct-slots
103 mop::class-direct-subclasses
104 mop::class-direct-superclasses
105 mop::eql-specializer
106 mop::class-finalized-p
107 cl:class-name
108 mop::class-precedence-list
109 class-prototype ;;dummy
110 class-slots
111 specializer-direct-methods
112 ;; eql-specializer accessors
113 mop::eql-specializer-object
114 ;; generic function readers
115 mop::generic-function-argument-precedence-order
116 generic-function-declarations ;;dummy
117 mop::generic-function-lambda-list
118 mop::generic-function-methods
119 mop::generic-function-method-class
120 mop::generic-function-method-combination
121 mop::generic-function-name
122 ;; method readers
123 method-generic-function
124 method-function
125 mop::method-lambda-list
126 mop::method-specializers
127 mop::method-qualifiers
128 ;; slot readers
129 mop::slot-definition-allocation
130 slot-definition-documentation ;;dummy
131 mop::slot-definition-initargs
132 mop::slot-definition-initform
133 mop::slot-definition-initfunction
134 slot-definition-name
135 slot-definition-type ;;dummy
136 mop::slot-definition-readers
137 mop::slot-definition-writers
138 slot-boundp-using-class
139 slot-value-using-class
140 ))
141
142 ;;;; TCP Server
143
144
145 (defimplementation preferred-communication-style ()
146 #+#.(cl:if (cl:find-package :threads) '(:and) '(:or))
147 :spawn
148 #-#.(cl:if (cl:find-package :threads) '(:and) '(:or))
149 nil
150 )
151
152 (defimplementation create-socket (host port)
153 (ext:make-server-socket port))
154
155 (defimplementation local-port (socket)
156 (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
157
158 (defimplementation close-socket (socket)
159 (ext:server-socket-close socket))
160
161 (defimplementation accept-connection (socket
162 &key external-format buffering timeout)
163 (declare (ignore buffering timeout))
164 (ext:get-socket-stream (ext:socket-accept socket)
165 :external-format external-format))
166
167 ;;;; External formats
168
169 (defvar *external-format-to-coding-system*
170 '((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1")
171 ((:iso-8859-1 :eol-style :lf) "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
172 (:utf-8 "utf-8")
173 ((:utf-8 :eol-style :lf) "utf-8-unix")
174 (:euc-jp "euc-jp")
175 ((:euc-jp :eol-style :lf) "euc-jp-unix")
176 (:us-ascii "us-ascii")
177 ((:us-ascii :eol-style :lf) "us-ascii-unix")))
178
179 (defimplementation find-external-format (coding-system)
180 (car (rassoc-if (lambda (x)
181 (member coding-system x :test #'equal))
182 *external-format-to-coding-system*)))
183
184 ;;;; Unix signals
185
186 (defimplementation getpid ()
187 (handler-case
188 (let* ((runtime
189 (java:jstatic "getRuntime" "java.lang.Runtime"))
190 (command
191 (java:jnew-array-from-array
192 "java.lang.String" #("sh" "-c" "echo $PPID")))
193 (runtime-exec-jmethod
194 ;; Complicated because java.lang.Runtime.exec() is
195 ;; overloaded on a non-primitive type (array of
196 ;; java.lang.String), so we have to use the actual
197 ;; parameter instance to get java.lang.Class
198 (java:jmethod "java.lang.Runtime" "exec"
199 (java:jcall
200 (java:jmethod "java.lang.Object" "getClass")
201 command)))
202 (process
203 (java:jcall runtime-exec-jmethod runtime command))
204 (output
205 (java:jcall (java:jmethod "java.lang.Process" "getInputStream")
206 process)))
207 (java:jcall (java:jmethod "java.lang.Process" "waitFor")
208 process)
209 (loop :with b :do
210 (setq b
211 (java:jcall (java:jmethod "java.io.InputStream" "read")
212 output))
213 :until (member b '(-1 #x0a)) ; Either EOF or LF
214 :collecting (code-char b) :into result
215 :finally (return
216 (parse-integer (coerce result 'string)))))
217 (t () 0)))
218
219 (defimplementation lisp-implementation-type-name ()
220 "armedbear")
221
222 (defimplementation set-default-directory (directory)
223 (let ((dir (sys::probe-directory directory)))
224 (when dir (setf *default-pathname-defaults* dir))
225 (namestring dir)))
226
227
228 ;;;; Misc
229
230 (defimplementation arglist (fun)
231 (cond ((symbolp fun)
232 (multiple-value-bind (arglist present)
233 (or (sys::arglist fun)
234 (and (fboundp fun)
235 (typep (symbol-function fun) 'standard-generic-function)
236 (let ((it (mop::generic-function-lambda-list (symbol-function fun))))
237 (values it it))))
238 (if present arglist :not-available)))
239 (t :not-available)))
240
241 (defimplementation function-name (function)
242 (nth-value 2 (function-lambda-expression function)))
243
244 (defimplementation macroexpand-all (form)
245 (macroexpand form))
246
247 (defimplementation describe-symbol-for-emacs (symbol)
248 (let ((result '()))
249 (flet ((doc (kind &optional (sym symbol))
250 (or (documentation sym kind) :not-documented))
251 (maybe-push (property value)
252 (when value
253 (setf result (list* property value result)))))
254 (maybe-push
255 :variable (when (boundp symbol)
256 (doc 'variable)))
257 (maybe-push
258 :function (if (fboundp symbol)
259 (doc 'function)))
260 (maybe-push
261 :class (if (find-class symbol nil)
262 (doc 'class)))
263 result)))
264
265
266 (defimplementation describe-definition (symbol namespace)
267 (ecase namespace
268 (:variable
269 (describe symbol))
270 ((:function :generic-function)
271 (describe (symbol-function symbol)))
272 (:class
273 (describe (find-class symbol)))))
274
275 (defimplementation describe-definition (symbol namespace)
276 (ecase namespace
277 (:variable
278 (describe symbol))
279 ((:function :generic-function)
280 (describe (symbol-function symbol)))
281 (:class
282 (describe (find-class symbol)))))
283
284
285 ;;;; Debugger
286
287 ;;; Copied from swank-sbcl.lisp.
288 (defun make-invoke-debugger-hook (hook)
289 #'(lambda (condition old-hook)
290 ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before
291 ;; *DEBUGGER-HOOK*, so we have to make sure that the latter gets
292 ;; run when it was established locally by a user (i.e. changed
293 ;; meanwhile.)
294 (if *debugger-hook*
295 (funcall *debugger-hook* condition old-hook)
296 (funcall hook condition old-hook))))
297
298 (defimplementation call-with-debugger-hook (hook fun)
299 (let ((*debugger-hook* hook)
300 #+#.(swank-backend::with-symbol '*invoke-debugger-hook* 'sys)
301 (sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
302 (funcall fun)))
303
304 (defimplementation install-debugger-globally (function)
305 (setq *debugger-hook* function)
306 #+#.(swank-backend::with-symbol '*invoke-debugger-hook* 'sys)
307 (setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function)))
308
309 (defvar *sldb-topframe*)
310
311 (defimplementation call-with-debugging-environment (debugger-loop-fn)
312 (let* ((magic-token (intern "SWANK-DEBUGGER-HOOK" 'swank))
313 (*sldb-topframe*
314 #+#.(swank-backend::with-symbol 'backtrace 'sys)
315 (second (member magic-token (sys:backtrace)
316 :key #'(lambda (frame)
317 (first (sys:frame-to-list frame)))))
318 #-#.(swank-backend::with-symbol 'backtrace 'sys)
319 (second (member magic-token (ext:backtrace-as-list)
320 :key #'(lambda (frame)
321 (first frame))))
322 ))
323 (funcall debugger-loop-fn)))
324
325 (defun backtrace (start end)
326 "A backtrace without initial SWANK frames."
327 (let ((backtrace
328 #+#.(swank-backend::with-symbol 'backtrace 'sys)
329 (sys:backtrace)
330 #-#.(swank-backend::with-symbol 'backtrace 'sys)
331 (ext:backtrace-as-list)
332 ))
333 (subseq (or (member *sldb-topframe* backtrace) backtrace)
334 start end)))
335
336 (defun nth-frame (index)
337 (nth index (backtrace 0 nil)))
338
339 (defimplementation compute-backtrace (start end)
340 (let ((end (or end most-positive-fixnum)))
341 (backtrace start end)))
342
343 (defimplementation print-frame (frame stream)
344 (write-string
345 #+#.(swank-backend::with-symbol 'backtrace 'sys)
346 (sys:frame-to-string frame)
347 #-#.(swank-backend::with-symbol 'backtrace 'sys)
348 (string-trim '(#\space #\newline) (prin1-to-string frame))
349 stream))
350
351 (defimplementation frame-locals (index)
352 `(,(list :name "??" :id 0 :value "??")))
353
354 #+nil
355 (defimplementation disassemble-frame (index)
356 (disassemble (debugger:frame-function (nth-frame index))))
357
358 (defimplementation frame-source-location (index)
359 (list :error (format nil "Cannot find source for frame: ~A"
360 (nth-frame index))))
361
362 #+nil
363 (defimplementation eval-in-frame (form frame-number)
364 (debugger:eval-form-in-context
365 form
366 (debugger:environment-of-frame (nth-frame frame-number))))
367
368 #+nil
369 (defimplementation return-from-frame (frame-number form)
370 (let ((frame (nth-frame frame-number)))
371 (multiple-value-call #'debugger:frame-return
372 frame (debugger:eval-form-in-context
373 form
374 (debugger:environment-of-frame frame)))))
375
376 ;;; XXX doesn't work for frames with arguments
377 #+nil
378 (defimplementation restart-frame (frame-number)
379 (let ((frame (nth-frame frame-number)))
380 (debugger:frame-retry frame (debugger:frame-function frame))))
381
382 ;;;; Compiler hooks
383
384 (defvar *buffer-name* nil)
385 (defvar *buffer-start-position*)
386 (defvar *buffer-string*)
387 (defvar *compile-filename*)
388
389 (in-package :swank-backend)
390
391 (defun handle-compiler-warning (condition)
392 (let ((loc (when (and jvm::*compile-file-pathname*
393 system::*source-position*)
394 (cons jvm::*compile-file-pathname* system::*source-position*))))
395 ;; filter condition signaled more than once.
396 (unless (member condition *abcl-signaled-conditions*)
397 (push condition *abcl-signaled-conditions*)
398 (signal (make-condition
399 'compiler-condition
400 :original-condition condition
401 :severity :warning
402 :message (format nil "~A" condition)
403 :location (cond (*buffer-name*
404 (make-location
405 (list :buffer *buffer-name*)
406 (list :offset *buffer-start-position* 0)))
407 (loc
408 (destructuring-bind (file . pos) loc
409 (make-location
410 (list :file (namestring (truename file)))
411 (list :position (1+ pos)))))
412 (t
413 (make-location
414 (list :file (namestring *compile-filename*))
415 (list :position 1)))))))))
416
417 (defvar *abcl-signaled-conditions*)
418
419 (defimplementation swank-compile-file (input-file output-file
420 load-p external-format)
421 (declare (ignore external-format))
422 (let ((jvm::*resignal-compiler-warnings* t)
423 (*abcl-signaled-conditions* nil))
424 (handler-bind ((warning #'handle-compiler-warning))
425 (let ((*buffer-name* nil)
426 (*compile-filename* input-file))
427 (multiple-value-bind (fn warn fail)
428 (compile-file input-file :output-file output-file)
429 (values fn warn
430 (and fn load-p
431 (not (load fn)))))))))
432
433 (defimplementation swank-compile-string (string &key buffer position filename
434 policy)
435 (declare (ignore filename policy))
436 (let ((jvm::*resignal-compiler-warnings* t)
437 (*abcl-signaled-conditions* nil))
438 (handler-bind ((warning #'handle-compiler-warning))
439 (let ((*buffer-name* buffer)
440 (*buffer-start-position* position)
441 (*buffer-string* string))
442 (funcall (compile nil (read-from-string
443 (format nil "(~S () ~A)" 'lambda string))))
444 t))))
445
446 #|
447 ;;;; Definition Finding
448
449 (defun find-fspec-location (fspec type)
450 (let ((file (excl::fspec-pathname fspec type)))
451 (etypecase file
452 (pathname
453 (let ((start (scm:find-definition-in-file fspec type file)))
454 (make-location (list :file (namestring (truename file)))
455 (if start
456 (list :position (1+ start))
457 (list :function-name (string fspec))))))
458 ((member :top-level)
459 (list :error (format nil "Defined at toplevel: ~A" fspec)))
460 (null
461 (list :error (format nil "Unkown source location for ~A" fspec))))))
462
463 (defun fspec-definition-locations (fspec)
464 (let ((defs (excl::find-multiple-definitions fspec)))
465 (loop for (fspec type) in defs
466 collect (list fspec (find-fspec-location fspec type)))))
467
468 (defimplementation find-definitions (symbol)
469 (fspec-definition-locations symbol))
470
471 |#
472
473 (defun source-location (symbol)
474 (when (pathnamep (ext:source-pathname symbol))
475 (let ((pos (ext:source-file-position symbol)))
476 `(((,symbol)
477 (:location
478 (:file ,(namestring (ext:source-pathname symbol)))
479 ,(if pos
480 (list :position (1+ pos))
481 (list :function-name (string symbol)))
482 (:align t)))))))
483
484 (defimplementation find-definitions (symbol)
485 (source-location symbol))
486
487 #|
488 Uncomment this if you have patched xref.lisp, as in
489 http://article.gmane.org/gmane.lisp.slime.devel/2425
490 Also, make sure that xref.lisp is loaded by modifying the armedbear
491 part of *sysdep-pathnames* in swank.loader.lisp.
492
493 ;;;; XREF
494 (setq pxref:*handle-package-forms* '(cl:in-package))
495
496 (defmacro defxref (name function)
497 `(defimplementation ,name (name)
498 (xref-results (,function name))))
499
500 (defxref who-calls pxref:list-callers)
501 (defxref who-references pxref:list-readers)
502 (defxref who-binds pxref:list-setters)
503 (defxref who-sets pxref:list-setters)
504 (defxref list-callers pxref:list-callers)
505 (defxref list-callees pxref:list-callees)
506
507 (defun xref-results (symbols)
508 (let ((xrefs '()))
509 (dolist (symbol symbols)
510 (push (list symbol (cadar (source-location symbol))) xrefs))
511 xrefs))
512 |#
513
514 ;;;; Inspecting
515
516 (defmethod emacs-inspect ((slot mop::slot-definition))
517 `("Name: " (:value ,(mop::%slot-definition-name slot))
518 (:newline)
519 "Documentation:" (:newline)
520 ,@(when (slot-definition-documentation slot)
521 `((:value ,(slot-definition-documentation slot)) (:newline)))
522 "Initialization:" (:newline)
523 " Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline)
524 " Form: " ,(if (mop::%slot-definition-initfunction slot)
525 `(:value ,(mop::%slot-definition-initform slot))
526 "#<unspecified>") (:newline)
527 " Function: " (:value ,(mop::%slot-definition-initfunction slot))
528 (:newline)))
529
530 (defmethod emacs-inspect ((f function))
531 `(,@(when (function-name f)
532 `("Name: "
533 ,(princ-to-string (function-name f)) (:newline)))
534 ,@(multiple-value-bind (args present)
535 (sys::arglist f)
536 (when present `("Argument list: " ,(princ-to-string args) (:newline))))
537 (:newline)
538 #+nil,@(when (documentation f t)
539 `("Documentation:" (:newline) ,(documentation f t) (:newline)))
540 ,@(when (function-lambda-expression f)
541 `("Lambda expression:"
542 (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline)))))
543
544 #|
545
546 (defmethod emacs-inspect ((o t))
547 (let* ((class (class-of o))
548 (slots (mop::class-slots class)))
549 (mapcar (lambda (slot)
550 (let ((name (mop::slot-definition-name slot)))
551 (cons (princ-to-string name)
552 (slot-value o name))))
553 slots)))
554 |#
555
556 ;;;; Multithreading
557
558 #+#.(cl:if (cl:find-package :threads) '(:and) '(:or))
559 (progn
560 (defimplementation spawn (fn &key name)
561 (threads:make-thread (lambda () (funcall fn)) :name name))
562
563 (defvar *thread-plists* (make-hash-table) ; should be a weak table
564 "A hashtable mapping threads to a plist.")
565
566 (defvar *thread-id-counter* 0)
567
568 (defimplementation thread-id (thread)
569 (threads:synchronized-on *thread-plists*
570 (or (getf (gethash thread *thread-plists*) 'id)
571 (setf (getf (gethash thread *thread-plists*) 'id)
572 (incf *thread-id-counter*)))))
573
574 (defimplementation find-thread (id)
575 (find id (all-threads)
576 :key (lambda (thread)
577 (getf (gethash thread *thread-plists*) 'id))))
578
579 (defimplementation thread-name (thread)
580 (threads:thread-name thread))
581
582 (defimplementation thread-status (thread)
583 (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread)))
584
585 (defimplementation make-lock (&key name)
586 (declare (ignore name))
587 (threads:make-thread-lock))
588
589 (defimplementation call-with-lock-held (lock function)
590 (threads:with-thread-lock (lock) (funcall function)))
591
592 (defimplementation current-thread ()
593 (threads:current-thread))
594
595 (defimplementation all-threads ()
596 (copy-list (threads:mapcar-threads #'identity)))
597
598 (defimplementation thread-alive-p (thread)
599 (member thread (all-threads)))
600
601 (defimplementation interrupt-thread (thread fn)
602 (threads:interrupt-thread thread fn))
603
604 (defimplementation kill-thread (thread)
605 (threads:destroy-thread thread))
606
607 (defstruct mailbox
608 (queue '()))
609
610 (defun mailbox (thread)
611 "Return THREAD's mailbox."
612 (threads:synchronized-on *thread-plists*
613 (or (getf (gethash thread *thread-plists*) 'mailbox)
614 (setf (getf (gethash thread *thread-plists*) 'mailbox)
615 (make-mailbox)))))
616
617 (defimplementation send (thread message)
618 (let ((mbox (mailbox thread)))
619 (threads:synchronized-on mbox
620 (setf (mailbox-queue mbox)
621 (nconc (mailbox-queue mbox) (list message)))
622 (threads:object-notify-all mbox))))
623
624 (defimplementation receive-if (test &optional timeout)
625 (let* ((mbox (mailbox (current-thread))))
626 (assert (or (not timeout) (eq timeout t)))
627 (loop
628 (check-slime-interrupts)
629 (threads:synchronized-on mbox
630 (let* ((q (mailbox-queue mbox))
631 (tail (member-if test q)))
632 (when tail
633 (setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail)))
634 (return (car tail)))
635 (when (eq timeout t) (return (values nil t)))
636 (threads:object-wait mbox 0.3)))))))
637
638 (defimplementation quit-lisp ()
639 (ext:exit))

  ViewVC Help
Powered by ViewVC 1.1.5