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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5