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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5