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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.77 - (show annotations)
Thu Nov 26 07:06:50 2009 UTC (4 years, 4 months ago) by mevenson
Branch: MAIN
Changes since 1.76: +10 -7 lines
swank-abcl.lisp (arglist):  Fixes for functions with non-nil
arglist and for generic functions with empty argument lists.

Contributed by Matthias.
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 (sys::arglist fun)
234 (when (and (not present)
235 (fboundp fun)
236 (typep (symbol-function fun) 'standard-generic-function))
237 (setq arglist
238 (mop::generic-function-lambda-list (symbol-function fun))
239 present
240 t))
241 (if present arglist :not-available)))
242 (t :not-available)))
243
244 (defimplementation function-name (function)
245 (nth-value 2 (function-lambda-expression function)))
246
247 (defimplementation macroexpand-all (form)
248 (macroexpand form))
249
250 (defimplementation describe-symbol-for-emacs (symbol)
251 (let ((result '()))
252 (flet ((doc (kind &optional (sym symbol))
253 (or (documentation sym kind) :not-documented))
254 (maybe-push (property value)
255 (when value
256 (setf result (list* property value result)))))
257 (maybe-push
258 :variable (when (boundp symbol)
259 (doc 'variable)))
260 (maybe-push
261 :function (if (fboundp symbol)
262 (doc 'function)))
263 (maybe-push
264 :class (if (find-class symbol nil)
265 (doc 'class)))
266 result)))
267
268
269 (defimplementation describe-definition (symbol namespace)
270 (ecase namespace
271 (:variable
272 (describe symbol))
273 ((:function :generic-function)
274 (describe (symbol-function symbol)))
275 (:class
276 (describe (find-class symbol)))))
277
278 (defimplementation describe-definition (symbol namespace)
279 (ecase namespace
280 (:variable
281 (describe symbol))
282 ((:function :generic-function)
283 (describe (symbol-function symbol)))
284 (:class
285 (describe (find-class symbol)))))
286
287
288 ;;;; Debugger
289
290 ;;; Copied from swank-sbcl.lisp.
291 (defun make-invoke-debugger-hook (hook)
292 #'(lambda (condition old-hook)
293 ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before
294 ;; *DEBUGGER-HOOK*, so we have to make sure that the latter gets
295 ;; run when it was established locally by a user (i.e. changed
296 ;; meanwhile.)
297 (if *debugger-hook*
298 (funcall *debugger-hook* condition old-hook)
299 (funcall hook condition old-hook))))
300
301 (defimplementation call-with-debugger-hook (hook fun)
302 (let ((*debugger-hook* hook)
303 #+#.(swank-backend::with-symbol '*invoke-debugger-hook* 'sys)
304 (sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
305 (funcall fun)))
306
307 (defimplementation install-debugger-globally (function)
308 (setq *debugger-hook* function)
309 #+#.(swank-backend::with-symbol '*invoke-debugger-hook* 'sys)
310 (setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function)))
311
312 (defvar *sldb-topframe*)
313
314 (defimplementation call-with-debugging-environment (debugger-loop-fn)
315 (let* ((magic-token (intern "SWANK-DEBUGGER-HOOK" 'swank))
316 (*sldb-topframe*
317 #+#.(swank-backend::with-symbol 'backtrace 'sys)
318 (second (member magic-token (sys:backtrace)
319 :key #'(lambda (frame)
320 (first (sys:frame-to-list frame)))))
321 #-#.(swank-backend::with-symbol 'backtrace 'sys)
322 (second (member magic-token (ext:backtrace-as-list)
323 :key #'(lambda (frame)
324 (first frame))))
325 ))
326 (funcall debugger-loop-fn)))
327
328 (defun backtrace (start end)
329 "A backtrace without initial SWANK frames."
330 (let ((backtrace
331 #+#.(swank-backend::with-symbol 'backtrace 'sys)
332 (sys:backtrace)
333 #-#.(swank-backend::with-symbol 'backtrace 'sys)
334 (ext:backtrace-as-list)
335 ))
336 (subseq (or (member *sldb-topframe* backtrace) backtrace)
337 start end)))
338
339 (defun nth-frame (index)
340 (nth index (backtrace 0 nil)))
341
342 (defimplementation compute-backtrace (start end)
343 (let ((end (or end most-positive-fixnum)))
344 (backtrace start end)))
345
346 (defimplementation print-frame (frame stream)
347 (write-string
348 #+#.(swank-backend::with-symbol 'backtrace 'sys)
349 (sys:frame-to-string frame)
350 #-#.(swank-backend::with-symbol 'backtrace 'sys)
351 (string-trim '(#\space #\newline) (prin1-to-string frame))
352 stream))
353
354 (defimplementation frame-locals (index)
355 `(,(list :name "??" :id 0 :value "??")))
356
357 #+nil
358 (defimplementation disassemble-frame (index)
359 (disassemble (debugger:frame-function (nth-frame index))))
360
361 (defimplementation frame-source-location (index)
362 (list :error (format nil "Cannot find source for frame: ~A"
363 (nth-frame index))))
364
365 #+nil
366 (defimplementation eval-in-frame (form frame-number)
367 (debugger:eval-form-in-context
368 form
369 (debugger:environment-of-frame (nth-frame frame-number))))
370
371 #+nil
372 (defimplementation return-from-frame (frame-number form)
373 (let ((frame (nth-frame frame-number)))
374 (multiple-value-call #'debugger:frame-return
375 frame (debugger:eval-form-in-context
376 form
377 (debugger:environment-of-frame frame)))))
378
379 ;;; XXX doesn't work for frames with arguments
380 #+nil
381 (defimplementation restart-frame (frame-number)
382 (let ((frame (nth-frame frame-number)))
383 (debugger:frame-retry frame (debugger:frame-function frame))))
384
385 ;;;; Compiler hooks
386
387 (defvar *buffer-name* nil)
388 (defvar *buffer-start-position*)
389 (defvar *buffer-string*)
390 (defvar *compile-filename*)
391
392 (in-package :swank-backend)
393
394 (defun handle-compiler-warning (condition)
395 (let ((loc (when (and jvm::*compile-file-pathname*
396 system::*source-position*)
397 (cons jvm::*compile-file-pathname* system::*source-position*))))
398 ;; filter condition signaled more than once.
399 (unless (member condition *abcl-signaled-conditions*)
400 (push condition *abcl-signaled-conditions*)
401 (signal (make-condition
402 'compiler-condition
403 :original-condition condition
404 :severity :warning
405 :message (format nil "~A" condition)
406 :location (cond (*buffer-name*
407 (make-location
408 (list :buffer *buffer-name*)
409 (list :offset *buffer-start-position* 0)))
410 (loc
411 (destructuring-bind (file . pos) loc
412 (make-location
413 (list :file (namestring (truename file)))
414 (list :position (1+ pos)))))
415 (t
416 (make-location
417 (list :file (namestring *compile-filename*))
418 (list :position 1)))))))))
419
420 (defvar *abcl-signaled-conditions*)
421
422 (defimplementation swank-compile-file (input-file output-file
423 load-p external-format)
424 (declare (ignore external-format))
425 (let ((jvm::*resignal-compiler-warnings* t)
426 (*abcl-signaled-conditions* nil))
427 (handler-bind ((warning #'handle-compiler-warning))
428 (let ((*buffer-name* nil)
429 (*compile-filename* input-file))
430 (multiple-value-bind (fn warn fail)
431 (compile-file input-file :output-file output-file)
432 (values fn warn
433 (and fn load-p
434 (not (load fn)))))))))
435
436 (defimplementation swank-compile-string (string &key buffer position filename
437 policy)
438 (declare (ignore filename policy))
439 (let ((jvm::*resignal-compiler-warnings* t)
440 (*abcl-signaled-conditions* nil))
441 (handler-bind ((warning #'handle-compiler-warning))
442 (let ((*buffer-name* buffer)
443 (*buffer-start-position* position)
444 (*buffer-string* string))
445 (funcall (compile nil (read-from-string
446 (format nil "(~S () ~A)" 'lambda string))))
447 t))))
448
449 #|
450 ;;;; Definition Finding
451
452 (defun find-fspec-location (fspec type)
453 (let ((file (excl::fspec-pathname fspec type)))
454 (etypecase file
455 (pathname
456 (let ((start (scm:find-definition-in-file fspec type file)))
457 (make-location (list :file (namestring (truename file)))
458 (if start
459 (list :position (1+ start))
460 (list :function-name (string fspec))))))
461 ((member :top-level)
462 (list :error (format nil "Defined at toplevel: ~A" fspec)))
463 (null
464 (list :error (format nil "Unkown source location for ~A" fspec))))))
465
466 (defun fspec-definition-locations (fspec)
467 (let ((defs (excl::find-multiple-definitions fspec)))
468 (loop for (fspec type) in defs
469 collect (list fspec (find-fspec-location fspec type)))))
470
471 (defimplementation find-definitions (symbol)
472 (fspec-definition-locations symbol))
473
474 |#
475
476 (defun source-location (symbol)
477 (when (pathnamep (ext:source-pathname symbol))
478 (let ((pos (ext:source-file-position symbol)))
479 `(((,symbol)
480 (:location
481 (:file ,(namestring (ext:source-pathname symbol)))
482 ,(if pos
483 (list :position (1+ pos))
484 (list :function-name (string symbol)))
485 (:align t)))))))
486
487 (defimplementation find-definitions (symbol)
488 (source-location symbol))
489
490 #|
491 Uncomment this if you have patched xref.lisp, as in
492 http://article.gmane.org/gmane.lisp.slime.devel/2425
493 Also, make sure that xref.lisp is loaded by modifying the armedbear
494 part of *sysdep-pathnames* in swank.loader.lisp.
495
496 ;;;; XREF
497 (setq pxref:*handle-package-forms* '(cl:in-package))
498
499 (defmacro defxref (name function)
500 `(defimplementation ,name (name)
501 (xref-results (,function name))))
502
503 (defxref who-calls pxref:list-callers)
504 (defxref who-references pxref:list-readers)
505 (defxref who-binds pxref:list-setters)
506 (defxref who-sets pxref:list-setters)
507 (defxref list-callers pxref:list-callers)
508 (defxref list-callees pxref:list-callees)
509
510 (defun xref-results (symbols)
511 (let ((xrefs '()))
512 (dolist (symbol symbols)
513 (push (list symbol (cadar (source-location symbol))) xrefs))
514 xrefs))
515 |#
516
517 ;;;; Inspecting
518
519 (defmethod emacs-inspect ((slot mop::slot-definition))
520 `("Name: " (:value ,(mop::%slot-definition-name slot))
521 (:newline)
522 "Documentation:" (:newline)
523 ,@(when (slot-definition-documentation slot)
524 `((:value ,(slot-definition-documentation slot)) (:newline)))
525 "Initialization:" (:newline)
526 " Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline)
527 " Form: " ,(if (mop::%slot-definition-initfunction slot)
528 `(:value ,(mop::%slot-definition-initform slot))
529 "#<unspecified>") (:newline)
530 " Function: " (:value ,(mop::%slot-definition-initfunction slot))
531 (:newline)))
532
533 (defmethod emacs-inspect ((f function))
534 `(,@(when (function-name f)
535 `("Name: "
536 ,(princ-to-string (function-name f)) (:newline)))
537 ,@(multiple-value-bind (args present)
538 (sys::arglist f)
539 (when present `("Argument list: " ,(princ-to-string args) (:newline))))
540 (:newline)
541 #+nil,@(when (documentation f t)
542 `("Documentation:" (:newline) ,(documentation f t) (:newline)))
543 ,@(when (function-lambda-expression f)
544 `("Lambda expression:"
545 (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline)))))
546
547 #|
548
549 (defmethod emacs-inspect ((o t))
550 (let* ((class (class-of o))
551 (slots (mop::class-slots class)))
552 (mapcar (lambda (slot)
553 (let ((name (mop::slot-definition-name slot)))
554 (cons (princ-to-string name)
555 (slot-value o name))))
556 slots)))
557 |#
558
559 ;;;; Multithreading
560
561 #+#.(cl:if (cl:find-package :threads) '(:and) '(:or))
562 (progn
563 (defimplementation spawn (fn &key name)
564 (threads:make-thread (lambda () (funcall fn)) :name name))
565
566 (defvar *thread-plists* (make-hash-table) ; should be a weak table
567 "A hashtable mapping threads to a plist.")
568
569 (defvar *thread-id-counter* 0)
570
571 (defimplementation thread-id (thread)
572 (threads:synchronized-on *thread-plists*
573 (or (getf (gethash thread *thread-plists*) 'id)
574 (setf (getf (gethash thread *thread-plists*) 'id)
575 (incf *thread-id-counter*)))))
576
577 (defimplementation find-thread (id)
578 (find id (all-threads)
579 :key (lambda (thread)
580 (getf (gethash thread *thread-plists*) 'id))))
581
582 (defimplementation thread-name (thread)
583 (threads:thread-name thread))
584
585 (defimplementation thread-status (thread)
586 (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread)))
587
588 (defimplementation make-lock (&key name)
589 (declare (ignore name))
590 (threads:make-thread-lock))
591
592 (defimplementation call-with-lock-held (lock function)
593 (threads:with-thread-lock (lock) (funcall function)))
594
595 (defimplementation current-thread ()
596 (threads:current-thread))
597
598 (defimplementation all-threads ()
599 (copy-list (threads:mapcar-threads #'identity)))
600
601 (defimplementation thread-alive-p (thread)
602 (member thread (all-threads)))
603
604 (defimplementation interrupt-thread (thread fn)
605 (threads:interrupt-thread thread fn))
606
607 (defimplementation kill-thread (thread)
608 (threads:destroy-thread thread))
609
610 (defstruct mailbox
611 (queue '()))
612
613 (defun mailbox (thread)
614 "Return THREAD's mailbox."
615 (threads:synchronized-on *thread-plists*
616 (or (getf (gethash thread *thread-plists*) 'mailbox)
617 (setf (getf (gethash thread *thread-plists*) 'mailbox)
618 (make-mailbox)))))
619
620 (defimplementation send (thread message)
621 (let ((mbox (mailbox thread)))
622 (threads:synchronized-on mbox
623 (setf (mailbox-queue mbox)
624 (nconc (mailbox-queue mbox) (list message)))
625 (threads:object-notify-all mbox))))
626
627 (defimplementation receive-if (test &optional timeout)
628 (let* ((mbox (mailbox (current-thread))))
629 (assert (or (not timeout) (eq timeout t)))
630 (loop
631 (check-slime-interrupts)
632 (threads:synchronized-on mbox
633 (let* ((q (mailbox-queue mbox))
634 (tail (member-if test q)))
635 (when tail
636 (setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail)))
637 (return (car tail)))
638 (when (eq timeout t) (return (values nil t)))
639 (threads:object-wait mbox 0.3)))))))
640
641 (defimplementation quit-lisp ()
642 (ext:exit))

  ViewVC Help
Powered by ViewVC 1.1.5