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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23 - (hide annotations)
Mon Nov 29 17:35:03 2004 UTC (9 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.22: +2 -1 lines
(accept-connection): The :external-format argument defaults now to
:iso-latin-1-unix.
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.23 (defimplementation accept-connection (socket
113     &key (external-format :iso-latin-1-unix))
114 heller 1.22 (assert (eq external-format :iso-latin-1-unix))
115 heller 1.1 (ext:get-socket-stream (ext:socket-accept socket)))
116    
117     ;;;; Unix signals
118    
119     (defimplementation call-without-interrupts (fn)
120     (funcall fn))
121    
122     ;;there are too many to count
123     (defimplementation getpid ()
124     0)
125    
126     (defimplementation lisp-implementation-type-name ()
127     "armedbear")
128    
129     (defimplementation set-default-directory (directory)
130     (let ((dir (sys::probe-directory directory)))
131     (when dir (setf *default-pathname-defaults* dir))
132     (namestring dir)))
133    
134    
135     ;;;; Misc
136    
137 asimon 1.13
138 asimon 1.17 (defimplementation arglist ((symbol t))
139     (multiple-value-bind (arglist present)
140     (sys::arglist symbol)
141     (if present arglist :not-available)))
142    
143 asimon 1.13
144     (defimplementation function-name (function)
145     (nth-value 2 (function-lambda-expression function)))
146 heller 1.1
147     (defimplementation macroexpand-all (form)
148     (macroexpand form))
149    
150     (defimplementation describe-symbol-for-emacs (symbol)
151     (let ((result '()))
152     (flet ((doc (kind &optional (sym symbol))
153     (or (documentation sym kind) :not-documented))
154     (maybe-push (property value)
155     (when value
156     (setf result (list* property value result)))))
157     (maybe-push
158     :variable (when (boundp symbol)
159     (doc 'variable)))
160     (maybe-push
161     :function (if (fboundp symbol)
162     (doc 'function)))
163     (maybe-push
164     :class (if (find-class symbol nil)
165     (doc 'class)))
166     result)))
167    
168    
169     (defimplementation describe-definition (symbol namespace)
170     (ecase namespace
171     (:variable
172     (describe symbol))
173     ((:function :generic-function)
174     (describe (symbol-function symbol)))
175     (:class
176     (describe (find-class symbol)))))
177    
178     (defimplementation describe-definition (symbol namespace)
179     (ecase namespace
180     (:variable
181     (describe symbol))
182     ((:function :generic-function)
183     (describe (symbol-function symbol)))
184     (:class
185     (describe (find-class symbol)))))
186    
187    
188     ;;;; Debugger
189    
190     (defvar *sldb-topframe*)
191    
192     (defimplementation call-with-debugging-environment (debugger-loop-fn)
193     (let ((*sldb-topframe* (car (ext:backtrace-as-list)) #+nil (excl::int-newest-frame)))
194     (funcall debugger-loop-fn)))
195    
196     (defun nth-frame (index)
197     (nth index (ext:backtrace-as-list)))
198    
199     (defimplementation compute-backtrace (start end)
200     (let ((end (or end most-positive-fixnum)))
201     (subseq (ext:backtrace-as-list) start end)))
202    
203     (defimplementation print-frame (frame stream)
204 asimon 1.11 (print frame stream))
205 heller 1.1
206     #+nil
207     (defimplementation frame-locals (index)
208     (let ((frame (nth-frame index)))
209     (loop for i from 0 below (debugger:frame-number-vars frame)
210     collect (list :name (debugger:frame-var-name frame i)
211     :id 0
212     :value (debugger:frame-var-value frame i)))))
213    
214     (defimplementation frame-catch-tags (index)
215     (declare (ignore index))
216     nil)
217    
218     #+nil
219     (defimplementation disassemble-frame (index)
220     (disassemble (debugger:frame-function (nth-frame index))))
221    
222     (defimplementation frame-source-location-for-emacs (index)
223     (list :error (format nil "Cannot find source for frame: ~A"
224     (nth-frame index))))
225    
226     #+nil
227     (defimplementation eval-in-frame (form frame-number)
228     (debugger:eval-form-in-context
229     form
230     (debugger:environment-of-frame (nth-frame frame-number))))
231    
232     #+nil
233     (defimplementation return-from-frame (frame-number form)
234     (let ((frame (nth-frame frame-number)))
235     (multiple-value-call #'debugger:frame-return
236     frame (debugger:eval-form-in-context
237     form
238     (debugger:environment-of-frame frame)))))
239    
240     ;;; XXX doesn't work for frames with arguments
241     #+nil
242     (defimplementation restart-frame (frame-number)
243     (let ((frame (nth-frame frame-number)))
244     (debugger:frame-retry frame (debugger:frame-function frame))))
245    
246     ;;;; Compiler hooks
247    
248     (defvar *buffer-name* nil)
249     (defvar *buffer-start-position*)
250     (defvar *buffer-string*)
251     (defvar *compile-filename*)
252    
253     (defun handle-compiler-warning (condition)
254     #+nil
255     (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
256     (signal (make-condition
257     'compiler-condition
258     :original-condition condition
259     :severity :warning
260     :message (format nil "~A" condition)
261     :location (cond (*buffer-name*
262     (make-location
263     (list :buffer *buffer-name*)
264     (list :position *buffer-start-position*)))
265     (loc
266     (destructuring-bind (file . pos) loc
267     (make-location
268     (list :file (namestring (truename file)))
269     (list :position (1+ pos)))))
270     (t
271     (make-location
272     (list :file *compile-filename*)
273     (list :position 1))))))))
274    
275     (defimplementation swank-compile-file (*compile-filename* load-p)
276     (handler-bind ((warning #'handle-compiler-warning))
277     (let ((*buffer-name* nil))
278     (multiple-value-bind (fn warn fail)
279     (compile-file *compile-filename*)
280     (when load-p (unless fail (load fn)))))))
281    
282 pseibel 1.10 (defimplementation swank-compile-string (string &key buffer position directory)
283     (declare (ignore directory))
284 heller 1.1 (handler-bind ((warning #'handle-compiler-warning))
285     (let ((*buffer-name* buffer)
286     (*buffer-start-position* position)
287     (*buffer-string* string))
288     (funcall (compile nil (read-from-string
289     (format nil "(~S () ~A)" 'lambda string)))))))
290    
291     #|
292     ;;;; Definition Finding
293    
294     (defun find-fspec-location (fspec type)
295     (let ((file (excl::fspec-pathname fspec type)))
296     (etypecase file
297     (pathname
298     (let ((start (scm:find-definition-in-file fspec type file)))
299     (make-location (list :file (namestring (truename file)))
300     (if start
301     (list :position (1+ start))
302     (list :function-name (string fspec))))))
303     ((member :top-level)
304     (list :error (format nil "Defined at toplevel: ~A" fspec)))
305     (null
306     (list :error (format nil "Unkown source location for ~A" fspec))))))
307    
308     (defun fspec-definition-locations (fspec)
309     (let ((defs (excl::find-multiple-definitions fspec)))
310     (loop for (fspec type) in defs
311     collect (list fspec (find-fspec-location fspec type)))))
312    
313     (defimplementation find-definitions (symbol)
314     (fspec-definition-locations symbol))
315    
316     |#
317    
318 asimon 1.2 (defun source-location (symbol)
319     (when (ext:source symbol)
320     `(((,symbol)
321     (:location
322     (:file ,(namestring (ext:source-pathname symbol)))
323 asimon 1.9 (:position ,(or (ext:source-file-position symbol) 0) t)
324 asimon 1.2 (:snippet nil))))))
325    
326    
327     (defimplementation find-definitions (symbol)
328     (source-location symbol))
329    
330 asimon 1.17 #|
331     Uncomment this if you have patched xref.lisp, as in
332     http://article.gmane.org/gmane.lisp.slime.devel/2425
333     Also, make sure that xref.lisp is loaded by modifying the armedbear
334     part of *sysdep-pathnames* in swank.loader.lisp.
335 asimon 1.2
336 heller 1.1 ;;;; XREF
337 asimon 1.17 (setq pxref:*handle-package-forms* '(cl:in-package))
338 heller 1.1
339     (defmacro defxref (name function)
340     `(defimplementation ,name (name)
341     (xref-results (,function name))))
342    
343     (defxref who-calls pxref:list-callers)
344     (defxref who-references pxref:list-readers)
345     (defxref who-binds pxref:list-setters)
346     (defxref who-sets pxref:list-setters)
347     (defxref list-callers pxref:list-callers)
348     (defxref list-callees pxref:list-callees)
349    
350     (defun xref-results (symbols)
351     (let ((xrefs '()))
352     (dolist (symbol symbols)
353 asimon 1.17 (push (list symbol (cadar (source-location symbol))) xrefs))
354 heller 1.1 xrefs))
355     |#
356    
357 asimon 1.15 ;;;; Inspecting
358    
359     (defclass abcl-inspector (inspector)
360     ())
361    
362     (defimplementation make-default-inspector ()
363     (make-instance 'abcl-inspector))
364    
365 asimon 1.16 (defmethod inspect-for-emacs ((slot sys::slot-definition) (inspector abcl-inspector))
366 asimon 1.15 (declare (ignore inspector))
367     (values "A slot."
368     `("Name: " (:value ,(sys::slot-definition-name slot))
369     (:newline)
370     "Documentation:" (:newline)
371     ,@(when (slot-definition-documentation slot)
372     `((:value ,(slot-definition-documentation slot)) (:newline)))
373     "Initialization:" (:newline)
374     " Args: " (:value ,(sys::slot-definition-initargs slot)) (:newline)
375     " Form: " ,(if (sys::slot-definition-initfunction slot)
376     `(:value ,(sys::slot-definition-initform slot))
377     "#<unspecified>") (:newline)
378     " Function: " (:value ,(sys::slot-definition-initfunction slot))
379     (:newline))))
380 asimon 1.16
381     (defmethod inspect-for-emacs ((f function) (inspector abcl-inspector))
382     (declare (ignore inspector))
383     (values "A function."
384 asimon 1.17 `(,@(when (function-name f)
385     `("Name: "
386     ,(princ-to-string (function-name f)) (:newline)))
387     ,@(multiple-value-bind (args present)
388     (sys::arglist f)
389     (when present `("Argument list: " ,(princ-to-string args) (:newline))))
390 asimon 1.16 (:newline)
391     #+nil,@(when (documentation f t)
392     `("Documentation:" (:newline) ,(documentation f t) (:newline)))
393     ,@(when (function-lambda-expression f)
394     `("Lambda expression:"
395 asimon 1.17 (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline))))))
396 asimon 1.15
397 heller 1.1 #|
398    
399 asimon 1.15 (defimplementation inspect-for-emacs ((o t) (inspector abcl-inspector))
400 heller 1.1 (let* ((class (class-of o))
401 asimon 1.15 (slots (sys::class-slots class)))
402 heller 1.1 (values (format nil "~A~% is a ~A" o class)
403     (mapcar (lambda (slot)
404 asimon 1.15 (let ((name (sys::slot-definition-name slot)))
405 heller 1.1 (cons (princ-to-string name)
406     (slot-value o name))))
407     slots))))
408     |#
409 asimon 1.15
410 heller 1.1 ;;;; Multithreading
411    
412     (defimplementation startup-multiprocessing ()
413     #+nil(mp:start-scheduler))
414    
415     (defimplementation spawn (fn &key name)
416 asimon 1.8 (ext:make-thread (lambda () (funcall fn)) :name name))
417 heller 1.1
418 heller 1.6 (defvar *thread-props-lock* (ext:make-thread-lock))
419    
420     (defvar *thread-props* (make-hash-table) ; should be a weak table
421     "A hashtable mapping threads to a plist.")
422    
423     (defvar *thread-id-counter* 0)
424    
425     (defimplementation thread-id (thread)
426     (ext:with-thread-lock (*thread-props-lock*)
427     (or (getf (gethash thread *thread-props*) 'id)
428     (setf (getf (gethash thread *thread-props*) 'id)
429     (incf *thread-id-counter*)))))
430    
431     (defimplementation find-thread (id)
432     (find id (all-threads)
433 asimon 1.7 :key (lambda (thread)
434 heller 1.6 (getf (gethash thread *thread-props*) 'id))))
435    
436 heller 1.1 (defimplementation thread-name (thread)
437 asimon 1.8 (ext:thread-name thread))
438 heller 1.1
439     (defimplementation thread-status (thread)
440 asimon 1.4 (format nil "Thread is ~:[dead~;alive~]" (ext:thread-alive-p thread)))
441 heller 1.1
442     (defimplementation make-lock (&key name)
443     (ext:make-thread-lock))
444    
445     (defimplementation call-with-lock-held (lock function)
446     (ext:with-thread-lock (lock) (funcall function)))
447    
448     (defimplementation current-thread ()
449     (ext:current-thread))
450    
451     (defimplementation all-threads ()
452     (copy-list (ext:mapcar-threads #'identity)))
453    
454     (defimplementation interrupt-thread (thread fn)
455     (ext:interrupt-thread thread fn))
456    
457     (defimplementation kill-thread (thread)
458     (ext:destroy-thread thread))
459    
460     (defun mailbox (thread)
461     "Return THREAD's mailbox."
462 heller 1.6 (ext:with-thread-lock (*thread-props-lock*)
463     (or (getf (gethash thread *thread-props*) 'mailbox)
464     (setf (getf (gethash thread *thread-props*) 'mailbox)
465 asimon 1.5 (ext:make-mailbox)))))
466 heller 1.1
467 asimon 1.5 (defimplementation send (thread object)
468     (ext:mailbox-send (mailbox thread) object))
469 heller 1.1
470     (defimplementation receive ()
471 asimon 1.5 (ext:mailbox-read (mailbox (ext:current-thread))))
472 heller 1.1
473     (defimplementation quit-lisp ()
474     (ext:exit))
475 asimon 1.12

  ViewVC Help
Powered by ViewVC 1.1.5