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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5