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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5