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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.35 - (hide annotations)
Sun Apr 16 23:33:38 2006 UTC (8 years ago) by asimon
Branch: MAIN
CVS Tags: SLIME-2-0
Changes since 1.34: +2 -2 lines
(accept-connection): New argument: timeout.
1 heller 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
2     ;;;
3     ;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME.
4     ;;;
5 asimon 1.9 ;;; Adapted from swank-acl.lisp, Andras Simon, 2004
6 heller 1.1 ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8 asimon 1.9 ;;; are disclaimed.
9 heller 1.1 ;;;
10    
11     (in-package :swank-backend)
12    
13    
14     (eval-when (:compile-toplevel :load-toplevel :execute)
15     (require :collect) ;just so that it doesn't spoil the flying letters
16 asimon 1.17 (require :pprint))
17    
18 heller 1.25 (defun sys::break (&optional (format-control "BREAK called")
19     &rest format-arguments)
20 aruttenberg 1.31 (let ((*saved-backtrace* (backtrace-as-list-ignoring-swank-calls)))
21 asimon 1.20 (with-simple-restart (continue "Return from BREAK.")
22     (invoke-debugger
23     (sys::%make-condition 'simple-condition
24     (list :format-control format-control
25     :format-arguments format-arguments))))
26     nil))
27    
28 asimon 1.19 (defimplementation make-fn-streams (input-fn output-fn)
29     (let* ((output (ext:make-slime-output-stream output-fn))
30     (input (ext:make-slime-input-stream input-fn output)))
31     (values input output)))
32 heller 1.1
33 aruttenberg 1.34 (defimplementation call-with-compilation-hooks (function)
34     (funcall function))
35    
36 asimon 1.12 ;;; swank-mop
37 asimon 1.13
38     ;;dummies:
39 asimon 1.15
40 asimon 1.12 (defclass standard-slot-definition ()())
41 asimon 1.15
42 asimon 1.13 (defun class-finalized-p (class) t)
43 asimon 1.15
44     (defun slot-definition-documentation (slot) #+nil (documentation slot 't))
45 asimon 1.13 (defun slot-definition-type (slot) t)
46 asimon 1.14 (defun class-prototype (class))
47     (defun generic-function-declarations (gf))
48 asimon 1.17 (defun specializer-direct-methods (spec) nil)
49 asimon 1.12
50     (import-to-swank-mop
51     '( ;; classes
52     cl:standard-generic-function
53     standard-slot-definition ;;dummy
54     cl:method
55     cl:standard-class
56     ;; standard-class readers
57 asimon 1.26 mop::class-default-initargs
58     mop::class-direct-default-initargs
59     mop::class-direct-slots
60     mop::class-direct-subclasses
61     mop::class-direct-superclasses
62     mop::eql-specializer
63 asimon 1.13 class-finalized-p ;;dummy
64 asimon 1.12 cl:class-name
65 asimon 1.26 mop::class-precedence-list
66 asimon 1.14 class-prototype ;;dummy
67 asimon 1.26 mop::class-slots
68 asimon 1.17 specializer-direct-methods ;;dummy
69     ;; eql-specializer accessors
70 asimon 1.26 mop::eql-specializer-object
71 asimon 1.12 ;; generic function readers
72 asimon 1.26 mop::generic-function-argument-precedence-order
73 asimon 1.14 generic-function-declarations ;;dummy
74 asimon 1.26 mop::generic-function-lambda-list
75     mop::generic-function-methods
76     mop::generic-function-method-class
77     mop::generic-function-method-combination
78     mop::generic-function-name
79 asimon 1.12 ;; method readers
80 asimon 1.26 mop::method-generic-function
81     mop::method-function
82     mop::method-lambda-list
83     mop::method-specializers
84     mop::method-qualifiers
85 asimon 1.12 ;; slot readers
86 asimon 1.26 mop::slot-definition-allocation
87 asimon 1.13 slot-definition-documentation ;;dummy
88 asimon 1.26 mop::slot-definition-initargs
89     mop::slot-definition-initform
90     mop::slot-definition-initfunction
91     mop::slot-definition-name
92 asimon 1.13 slot-definition-type ;;dummy
93 asimon 1.26 mop::slot-definition-readers
94     mop::slot-definition-writers))
95 asimon 1.12
96 heller 1.1 ;;;; TCP Server
97    
98    
99     (defimplementation preferred-communication-style ()
100     :spawn)
101    
102    
103    
104     (defimplementation create-socket (host port)
105     (ext:make-server-socket port))
106    
107    
108     (defimplementation local-port (socket)
109     (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
110    
111    
112     (defimplementation close-socket (socket)
113     (ext:server-socket-close socket))
114    
115 heller 1.23 (defimplementation accept-connection (socket
116 asimon 1.35 &key (external-format :iso-latin-1-unix) buffering timeout)
117     (declare (ignore buffering timeout))
118 heller 1.22 (assert (eq external-format :iso-latin-1-unix))
119 heller 1.1 (ext:get-socket-stream (ext:socket-accept socket)))
120    
121     ;;;; Unix signals
122    
123     (defimplementation call-without-interrupts (fn)
124     (funcall fn))
125    
126     ;;there are too many to count
127     (defimplementation getpid ()
128     0)
129    
130     (defimplementation lisp-implementation-type-name ()
131     "armedbear")
132    
133     (defimplementation set-default-directory (directory)
134     (let ((dir (sys::probe-directory directory)))
135     (when dir (setf *default-pathname-defaults* dir))
136     (namestring dir)))
137    
138    
139     ;;;; Misc
140    
141 asimon 1.13
142 asimon 1.17 (defimplementation arglist ((symbol t))
143     (multiple-value-bind (arglist present)
144     (sys::arglist symbol)
145     (if present arglist :not-available)))
146    
147 asimon 1.13
148     (defimplementation function-name (function)
149     (nth-value 2 (function-lambda-expression function)))
150 heller 1.1
151     (defimplementation macroexpand-all (form)
152     (macroexpand form))
153    
154     (defimplementation describe-symbol-for-emacs (symbol)
155     (let ((result '()))
156     (flet ((doc (kind &optional (sym symbol))
157     (or (documentation sym kind) :not-documented))
158     (maybe-push (property value)
159     (when value
160     (setf result (list* property value result)))))
161     (maybe-push
162     :variable (when (boundp symbol)
163     (doc 'variable)))
164     (maybe-push
165     :function (if (fboundp symbol)
166     (doc 'function)))
167     (maybe-push
168     :class (if (find-class symbol nil)
169     (doc 'class)))
170     result)))
171    
172    
173     (defimplementation describe-definition (symbol namespace)
174     (ecase namespace
175     (:variable
176     (describe symbol))
177     ((:function :generic-function)
178     (describe (symbol-function symbol)))
179     (:class
180     (describe (find-class symbol)))))
181    
182     (defimplementation describe-definition (symbol namespace)
183     (ecase namespace
184     (:variable
185     (describe symbol))
186     ((:function :generic-function)
187     (describe (symbol-function symbol)))
188     (:class
189     (describe (find-class symbol)))))
190    
191    
192     ;;;; Debugger
193    
194     (defvar *sldb-topframe*)
195    
196 aruttenberg 1.31 (defun backtrace-as-list-ignoring-swank-calls ()
197     (let ((list (ext:backtrace-as-list)))
198 aruttenberg 1.33 (subseq list (1+ (or (position (intern "SWANK-DEBUGGER-HOOK" 'swank) list :key 'car) -1)))))
199 aruttenberg 1.31
200 heller 1.1 (defimplementation call-with-debugging-environment (debugger-loop-fn)
201 aruttenberg 1.31 (let ((*sldb-topframe* (car (backtrace-as-list-ignoring-swank-calls)) #+nil (excl::int-newest-frame)))
202 heller 1.1 (funcall debugger-loop-fn)))
203    
204     (defun nth-frame (index)
205 aruttenberg 1.31 (nth index (backtrace-as-list-ignoring-swank-calls)))
206 heller 1.1
207     (defimplementation compute-backtrace (start end)
208     (let ((end (or end most-positive-fixnum)))
209 aruttenberg 1.31 (subseq (backtrace-as-list-ignoring-swank-calls) start end)))
210 heller 1.1
211     (defimplementation print-frame (frame stream)
212 heller 1.25 (write-string (string-trim '(#\space #\newline)
213     (prin1-to-string frame))
214     stream))
215 heller 1.1
216     (defimplementation frame-locals (index)
217 aruttenberg 1.31 `(,(list :name "??" :id 0 :value "??")))
218 heller 1.25
219 heller 1.1
220     (defimplementation frame-catch-tags (index)
221     (declare (ignore index))
222     nil)
223    
224     #+nil
225     (defimplementation disassemble-frame (index)
226     (disassemble (debugger:frame-function (nth-frame index))))
227    
228     (defimplementation frame-source-location-for-emacs (index)
229     (list :error (format nil "Cannot find source for frame: ~A"
230     (nth-frame index))))
231    
232     #+nil
233     (defimplementation eval-in-frame (form frame-number)
234     (debugger:eval-form-in-context
235     form
236     (debugger:environment-of-frame (nth-frame frame-number))))
237    
238     #+nil
239     (defimplementation return-from-frame (frame-number form)
240     (let ((frame (nth-frame frame-number)))
241     (multiple-value-call #'debugger:frame-return
242     frame (debugger:eval-form-in-context
243     form
244     (debugger:environment-of-frame frame)))))
245    
246     ;;; XXX doesn't work for frames with arguments
247     #+nil
248     (defimplementation restart-frame (frame-number)
249     (let ((frame (nth-frame frame-number)))
250     (debugger:frame-retry frame (debugger:frame-function frame))))
251    
252     ;;;; Compiler hooks
253    
254     (defvar *buffer-name* nil)
255     (defvar *buffer-start-position*)
256     (defvar *buffer-string*)
257     (defvar *compile-filename*)
258    
259     (defun handle-compiler-warning (condition)
260     #+nil
261     (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
262     (signal (make-condition
263     'compiler-condition
264     :original-condition condition
265     :severity :warning
266     :message (format nil "~A" condition)
267     :location (cond (*buffer-name*
268     (make-location
269     (list :buffer *buffer-name*)
270     (list :position *buffer-start-position*)))
271     (loc
272     (destructuring-bind (file . pos) loc
273     (make-location
274     (list :file (namestring (truename file)))
275     (list :position (1+ pos)))))
276     (t
277     (make-location
278     (list :file *compile-filename*)
279     (list :position 1))))))))
280    
281 heller 1.27 (defimplementation swank-compile-file (filename load-p
282     &optional external-format)
283     (declare (ignore external-format))
284 heller 1.1 (handler-bind ((warning #'handle-compiler-warning))
285 heller 1.27 (let ((*buffer-name* nil)
286     (*compile-filename* filename))
287     (multiple-value-bind (fn warn fail) (compile-file filename)
288     (when (and load-p (not fail))
289     (load fn))))))
290 heller 1.1
291 pseibel 1.10 (defimplementation swank-compile-string (string &key buffer position directory)
292     (declare (ignore directory))
293 heller 1.1 (handler-bind ((warning #'handle-compiler-warning))
294     (let ((*buffer-name* buffer)
295     (*buffer-start-position* position)
296     (*buffer-string* string))
297     (funcall (compile nil (read-from-string
298     (format nil "(~S () ~A)" 'lambda string)))))))
299    
300     #|
301     ;;;; Definition Finding
302    
303     (defun find-fspec-location (fspec type)
304     (let ((file (excl::fspec-pathname fspec type)))
305     (etypecase file
306     (pathname
307     (let ((start (scm:find-definition-in-file fspec type file)))
308     (make-location (list :file (namestring (truename file)))
309     (if start
310     (list :position (1+ start))
311     (list :function-name (string fspec))))))
312     ((member :top-level)
313     (list :error (format nil "Defined at toplevel: ~A" fspec)))
314     (null
315     (list :error (format nil "Unkown source location for ~A" fspec))))))
316    
317     (defun fspec-definition-locations (fspec)
318     (let ((defs (excl::find-multiple-definitions fspec)))
319     (loop for (fspec type) in defs
320     collect (list fspec (find-fspec-location fspec type)))))
321    
322     (defimplementation find-definitions (symbol)
323     (fspec-definition-locations symbol))
324    
325     |#
326    
327 asimon 1.2 (defun source-location (symbol)
328 asimon 1.24 (when (pathnamep (ext:source-pathname symbol))
329 asimon 1.2 `(((,symbol)
330     (:location
331     (:file ,(namestring (ext:source-pathname symbol)))
332 asimon 1.9 (:position ,(or (ext:source-file-position symbol) 0) t)
333 asimon 1.2 (:snippet nil))))))
334 asimon 1.24
335 asimon 1.2
336     (defimplementation find-definitions (symbol)
337     (source-location symbol))
338    
339 asimon 1.17 #|
340     Uncomment this if you have patched xref.lisp, as in
341     http://article.gmane.org/gmane.lisp.slime.devel/2425
342     Also, make sure that xref.lisp is loaded by modifying the armedbear
343     part of *sysdep-pathnames* in swank.loader.lisp.
344 asimon 1.2
345 heller 1.1 ;;;; XREF
346 asimon 1.17 (setq pxref:*handle-package-forms* '(cl:in-package))
347 heller 1.1
348     (defmacro defxref (name function)
349     `(defimplementation ,name (name)
350     (xref-results (,function name))))
351    
352     (defxref who-calls pxref:list-callers)
353     (defxref who-references pxref:list-readers)
354     (defxref who-binds pxref:list-setters)
355     (defxref who-sets pxref:list-setters)
356     (defxref list-callers pxref:list-callers)
357     (defxref list-callees pxref:list-callees)
358    
359     (defun xref-results (symbols)
360     (let ((xrefs '()))
361     (dolist (symbol symbols)
362 asimon 1.17 (push (list symbol (cadar (source-location symbol))) xrefs))
363 heller 1.1 xrefs))
364     |#
365    
366 asimon 1.15 ;;;; Inspecting
367    
368     (defclass abcl-inspector (inspector)
369     ())
370    
371     (defimplementation make-default-inspector ()
372     (make-instance 'abcl-inspector))
373    
374 asimon 1.26 (defmethod inspect-for-emacs ((slot mop::slot-definition) (inspector abcl-inspector))
375 asimon 1.15 (declare (ignore inspector))
376     (values "A slot."
377 asimon 1.28 `("Name: " (:value ,(mop::%slot-definition-name slot))
378 asimon 1.15 (:newline)
379     "Documentation:" (:newline)
380     ,@(when (slot-definition-documentation slot)
381     `((:value ,(slot-definition-documentation slot)) (:newline)))
382     "Initialization:" (:newline)
383 asimon 1.28 " Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline)
384     " Form: " ,(if (mop::%slot-definition-initfunction slot)
385     `(:value ,(mop::%slot-definition-initform slot))
386 asimon 1.15 "#<unspecified>") (:newline)
387 asimon 1.28 " Function: " (:value ,(mop::%slot-definition-initfunction slot))
388 asimon 1.15 (:newline))))
389 asimon 1.16
390     (defmethod inspect-for-emacs ((f function) (inspector abcl-inspector))
391     (declare (ignore inspector))
392     (values "A function."
393 asimon 1.17 `(,@(when (function-name f)
394     `("Name: "
395     ,(princ-to-string (function-name f)) (:newline)))
396     ,@(multiple-value-bind (args present)
397     (sys::arglist f)
398     (when present `("Argument list: " ,(princ-to-string args) (:newline))))
399 asimon 1.16 (:newline)
400     #+nil,@(when (documentation f t)
401     `("Documentation:" (:newline) ,(documentation f t) (:newline)))
402     ,@(when (function-lambda-expression f)
403     `("Lambda expression:"
404 asimon 1.17 (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline))))))
405 asimon 1.15
406 heller 1.1 #|
407    
408 asimon 1.15 (defimplementation inspect-for-emacs ((o t) (inspector abcl-inspector))
409 heller 1.1 (let* ((class (class-of o))
410 asimon 1.26 (slots (mop::class-slots class)))
411 heller 1.1 (values (format nil "~A~% is a ~A" o class)
412     (mapcar (lambda (slot)
413 asimon 1.26 (let ((name (mop::slot-definition-name slot)))
414 heller 1.1 (cons (princ-to-string name)
415     (slot-value o name))))
416     slots))))
417     |#
418 asimon 1.15
419 heller 1.1 ;;;; Multithreading
420    
421     (defimplementation startup-multiprocessing ()
422     #+nil(mp:start-scheduler))
423    
424     (defimplementation spawn (fn &key name)
425 asimon 1.8 (ext:make-thread (lambda () (funcall fn)) :name name))
426 heller 1.1
427 heller 1.6 (defvar *thread-props-lock* (ext:make-thread-lock))
428    
429     (defvar *thread-props* (make-hash-table) ; should be a weak table
430     "A hashtable mapping threads to a plist.")
431    
432     (defvar *thread-id-counter* 0)
433    
434     (defimplementation thread-id (thread)
435     (ext:with-thread-lock (*thread-props-lock*)
436     (or (getf (gethash thread *thread-props*) 'id)
437     (setf (getf (gethash thread *thread-props*) 'id)
438     (incf *thread-id-counter*)))))
439    
440     (defimplementation find-thread (id)
441     (find id (all-threads)
442 asimon 1.7 :key (lambda (thread)
443 heller 1.6 (getf (gethash thread *thread-props*) 'id))))
444    
445 heller 1.1 (defimplementation thread-name (thread)
446 asimon 1.8 (ext:thread-name thread))
447 heller 1.1
448     (defimplementation thread-status (thread)
449 asimon 1.4 (format nil "Thread is ~:[dead~;alive~]" (ext:thread-alive-p thread)))
450 heller 1.1
451     (defimplementation make-lock (&key name)
452     (ext:make-thread-lock))
453    
454     (defimplementation call-with-lock-held (lock function)
455     (ext:with-thread-lock (lock) (funcall function)))
456    
457     (defimplementation current-thread ()
458     (ext:current-thread))
459    
460     (defimplementation all-threads ()
461     (copy-list (ext:mapcar-threads #'identity)))
462    
463     (defimplementation interrupt-thread (thread fn)
464     (ext:interrupt-thread thread fn))
465    
466     (defimplementation kill-thread (thread)
467     (ext:destroy-thread thread))
468    
469     (defun mailbox (thread)
470     "Return THREAD's mailbox."
471 heller 1.6 (ext:with-thread-lock (*thread-props-lock*)
472     (or (getf (gethash thread *thread-props*) 'mailbox)
473     (setf (getf (gethash thread *thread-props*) 'mailbox)
474 asimon 1.5 (ext:make-mailbox)))))
475 heller 1.1
476 asimon 1.5 (defimplementation send (thread object)
477     (ext:mailbox-send (mailbox thread) object))
478 heller 1.1
479     (defimplementation receive ()
480 asimon 1.5 (ext:mailbox-read (mailbox (ext:current-thread))))
481 heller 1.1
482 asimon 1.29 ;;; Auto-flush streams
483    
484     ;; XXX race conditions
485     (defvar *auto-flush-streams* '())
486    
487     (defvar *auto-flush-thread* nil)
488    
489     (defimplementation make-stream-interactive (stream)
490     (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*))
491     (unless *auto-flush-thread*
492     (setq *auto-flush-thread*
493     (ext:make-thread #'flush-streams
494     :name "auto-flush-thread"))))
495    
496     (defun flush-streams ()
497     (loop
498     (setq *auto-flush-streams*
499     (remove-if (lambda (x)
500     (not (and (open-stream-p x)
501     (output-stream-p x))))
502     *auto-flush-streams*))
503     (mapc #'finish-output *auto-flush-streams*)
504     (sleep 0.15)))
505    
506 heller 1.1 (defimplementation quit-lisp ()
507     (ext:exit))
508 asimon 1.12

  ViewVC Help
Powered by ViewVC 1.1.5