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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (hide annotations)
Sun Nov 13 17:27:40 2005 UTC (8 years, 5 months ago) by asimon
Branch: MAIN
Changes since 1.29: +2 -1 lines
(accept-connection): New argument: buffering.
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 asimon 1.30 &key (external-format :iso-latin-1-unix) buffering)
115     (declare (ignore buffering))
116 heller 1.22 (assert (eq external-format :iso-latin-1-unix))
117 heller 1.1 (ext:get-socket-stream (ext:socket-accept socket)))
118    
119     ;;;; Unix signals
120    
121     (defimplementation call-without-interrupts (fn)
122     (funcall fn))
123    
124     ;;there are too many to count
125     (defimplementation getpid ()
126     0)
127    
128     (defimplementation lisp-implementation-type-name ()
129     "armedbear")
130    
131     (defimplementation set-default-directory (directory)
132     (let ((dir (sys::probe-directory directory)))
133     (when dir (setf *default-pathname-defaults* dir))
134     (namestring dir)))
135    
136    
137     ;;;; Misc
138    
139 asimon 1.13
140 asimon 1.17 (defimplementation arglist ((symbol t))
141     (multiple-value-bind (arglist present)
142     (sys::arglist symbol)
143     (if present arglist :not-available)))
144    
145 asimon 1.13
146     (defimplementation function-name (function)
147     (nth-value 2 (function-lambda-expression function)))
148 heller 1.1
149     (defimplementation macroexpand-all (form)
150     (macroexpand form))
151    
152     (defimplementation describe-symbol-for-emacs (symbol)
153     (let ((result '()))
154     (flet ((doc (kind &optional (sym symbol))
155     (or (documentation sym kind) :not-documented))
156     (maybe-push (property value)
157     (when value
158     (setf result (list* property value result)))))
159     (maybe-push
160     :variable (when (boundp symbol)
161     (doc 'variable)))
162     (maybe-push
163     :function (if (fboundp symbol)
164     (doc 'function)))
165     (maybe-push
166     :class (if (find-class symbol nil)
167     (doc 'class)))
168     result)))
169    
170    
171     (defimplementation describe-definition (symbol namespace)
172     (ecase namespace
173     (:variable
174     (describe symbol))
175     ((:function :generic-function)
176     (describe (symbol-function symbol)))
177     (:class
178     (describe (find-class symbol)))))
179    
180     (defimplementation describe-definition (symbol namespace)
181     (ecase namespace
182     (:variable
183     (describe symbol))
184     ((:function :generic-function)
185     (describe (symbol-function symbol)))
186     (:class
187     (describe (find-class symbol)))))
188    
189    
190     ;;;; Debugger
191    
192     (defvar *sldb-topframe*)
193    
194     (defimplementation call-with-debugging-environment (debugger-loop-fn)
195     (let ((*sldb-topframe* (car (ext:backtrace-as-list)) #+nil (excl::int-newest-frame)))
196     (funcall debugger-loop-fn)))
197    
198     (defun nth-frame (index)
199     (nth index (ext:backtrace-as-list)))
200    
201     (defimplementation compute-backtrace (start end)
202     (let ((end (or end most-positive-fixnum)))
203     (subseq (ext:backtrace-as-list) start end)))
204    
205     (defimplementation print-frame (frame stream)
206 heller 1.25 (write-string (string-trim '(#\space #\newline)
207     (prin1-to-string frame))
208     stream))
209 heller 1.1
210     (defimplementation frame-locals (index)
211 heller 1.25 `((list :name "??" :id 0 :value "??")))
212    
213 heller 1.1
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 heller 1.27 (defimplementation swank-compile-file (filename load-p
276     &optional external-format)
277     (declare (ignore external-format))
278 heller 1.1 (handler-bind ((warning #'handle-compiler-warning))
279 heller 1.27 (let ((*buffer-name* nil)
280     (*compile-filename* filename))
281     (multiple-value-bind (fn warn fail) (compile-file filename)
282     (when (and load-p (not fail))
283     (load fn))))))
284 heller 1.1
285 pseibel 1.10 (defimplementation swank-compile-string (string &key buffer position directory)
286     (declare (ignore directory))
287 heller 1.1 (handler-bind ((warning #'handle-compiler-warning))
288     (let ((*buffer-name* buffer)
289     (*buffer-start-position* position)
290     (*buffer-string* string))
291     (funcall (compile nil (read-from-string
292     (format nil "(~S () ~A)" 'lambda string)))))))
293    
294     #|
295     ;;;; Definition Finding
296    
297     (defun find-fspec-location (fspec type)
298     (let ((file (excl::fspec-pathname fspec type)))
299     (etypecase file
300     (pathname
301     (let ((start (scm:find-definition-in-file fspec type file)))
302     (make-location (list :file (namestring (truename file)))
303     (if start
304     (list :position (1+ start))
305     (list :function-name (string fspec))))))
306     ((member :top-level)
307     (list :error (format nil "Defined at toplevel: ~A" fspec)))
308     (null
309     (list :error (format nil "Unkown source location for ~A" fspec))))))
310    
311     (defun fspec-definition-locations (fspec)
312     (let ((defs (excl::find-multiple-definitions fspec)))
313     (loop for (fspec type) in defs
314     collect (list fspec (find-fspec-location fspec type)))))
315    
316     (defimplementation find-definitions (symbol)
317     (fspec-definition-locations symbol))
318    
319     |#
320    
321 asimon 1.2 (defun source-location (symbol)
322 asimon 1.24 (when (pathnamep (ext:source-pathname symbol))
323 asimon 1.2 `(((,symbol)
324     (:location
325     (:file ,(namestring (ext:source-pathname symbol)))
326 asimon 1.9 (:position ,(or (ext:source-file-position symbol) 0) t)
327 asimon 1.2 (:snippet nil))))))
328 asimon 1.24
329 asimon 1.2
330     (defimplementation find-definitions (symbol)
331     (source-location symbol))
332    
333 asimon 1.17 #|
334     Uncomment this if you have patched xref.lisp, as in
335     http://article.gmane.org/gmane.lisp.slime.devel/2425
336     Also, make sure that xref.lisp is loaded by modifying the armedbear
337     part of *sysdep-pathnames* in swank.loader.lisp.
338 asimon 1.2
339 heller 1.1 ;;;; XREF
340 asimon 1.17 (setq pxref:*handle-package-forms* '(cl:in-package))
341 heller 1.1
342     (defmacro defxref (name function)
343     `(defimplementation ,name (name)
344     (xref-results (,function name))))
345    
346     (defxref who-calls pxref:list-callers)
347     (defxref who-references pxref:list-readers)
348     (defxref who-binds pxref:list-setters)
349     (defxref who-sets pxref:list-setters)
350     (defxref list-callers pxref:list-callers)
351     (defxref list-callees pxref:list-callees)
352    
353     (defun xref-results (symbols)
354     (let ((xrefs '()))
355     (dolist (symbol symbols)
356 asimon 1.17 (push (list symbol (cadar (source-location symbol))) xrefs))
357 heller 1.1 xrefs))
358     |#
359    
360 asimon 1.15 ;;;; Inspecting
361    
362     (defclass abcl-inspector (inspector)
363     ())
364    
365     (defimplementation make-default-inspector ()
366     (make-instance 'abcl-inspector))
367    
368 asimon 1.26 (defmethod inspect-for-emacs ((slot mop::slot-definition) (inspector abcl-inspector))
369 asimon 1.15 (declare (ignore inspector))
370     (values "A slot."
371 asimon 1.28 `("Name: " (:value ,(mop::%slot-definition-name slot))
372 asimon 1.15 (:newline)
373     "Documentation:" (:newline)
374     ,@(when (slot-definition-documentation slot)
375     `((:value ,(slot-definition-documentation slot)) (:newline)))
376     "Initialization:" (:newline)
377 asimon 1.28 " Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline)
378     " Form: " ,(if (mop::%slot-definition-initfunction slot)
379     `(:value ,(mop::%slot-definition-initform slot))
380 asimon 1.15 "#<unspecified>") (:newline)
381 asimon 1.28 " Function: " (:value ,(mop::%slot-definition-initfunction slot))
382 asimon 1.15 (:newline))))
383 asimon 1.16
384     (defmethod inspect-for-emacs ((f function) (inspector abcl-inspector))
385     (declare (ignore inspector))
386     (values "A function."
387 asimon 1.17 `(,@(when (function-name f)
388     `("Name: "
389     ,(princ-to-string (function-name f)) (:newline)))
390     ,@(multiple-value-bind (args present)
391     (sys::arglist f)
392     (when present `("Argument list: " ,(princ-to-string args) (:newline))))
393 asimon 1.16 (:newline)
394     #+nil,@(when (documentation f t)
395     `("Documentation:" (:newline) ,(documentation f t) (:newline)))
396     ,@(when (function-lambda-expression f)
397     `("Lambda expression:"
398 asimon 1.17 (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline))))))
399 asimon 1.15
400 heller 1.1 #|
401    
402 asimon 1.15 (defimplementation inspect-for-emacs ((o t) (inspector abcl-inspector))
403 heller 1.1 (let* ((class (class-of o))
404 asimon 1.26 (slots (mop::class-slots class)))
405 heller 1.1 (values (format nil "~A~% is a ~A" o class)
406     (mapcar (lambda (slot)
407 asimon 1.26 (let ((name (mop::slot-definition-name slot)))
408 heller 1.1 (cons (princ-to-string name)
409     (slot-value o name))))
410     slots))))
411     |#
412 asimon 1.15
413 heller 1.1 ;;;; Multithreading
414    
415     (defimplementation startup-multiprocessing ()
416     #+nil(mp:start-scheduler))
417    
418     (defimplementation spawn (fn &key name)
419 asimon 1.8 (ext:make-thread (lambda () (funcall fn)) :name name))
420 heller 1.1
421 heller 1.6 (defvar *thread-props-lock* (ext:make-thread-lock))
422    
423     (defvar *thread-props* (make-hash-table) ; should be a weak table
424     "A hashtable mapping threads to a plist.")
425    
426     (defvar *thread-id-counter* 0)
427    
428     (defimplementation thread-id (thread)
429     (ext:with-thread-lock (*thread-props-lock*)
430     (or (getf (gethash thread *thread-props*) 'id)
431     (setf (getf (gethash thread *thread-props*) 'id)
432     (incf *thread-id-counter*)))))
433    
434     (defimplementation find-thread (id)
435     (find id (all-threads)
436 asimon 1.7 :key (lambda (thread)
437 heller 1.6 (getf (gethash thread *thread-props*) 'id))))
438    
439 heller 1.1 (defimplementation thread-name (thread)
440 asimon 1.8 (ext:thread-name thread))
441 heller 1.1
442     (defimplementation thread-status (thread)
443 asimon 1.4 (format nil "Thread is ~:[dead~;alive~]" (ext:thread-alive-p thread)))
444 heller 1.1
445     (defimplementation make-lock (&key name)
446     (ext:make-thread-lock))
447    
448     (defimplementation call-with-lock-held (lock function)
449     (ext:with-thread-lock (lock) (funcall function)))
450    
451     (defimplementation current-thread ()
452     (ext:current-thread))
453    
454     (defimplementation all-threads ()
455     (copy-list (ext:mapcar-threads #'identity)))
456    
457     (defimplementation interrupt-thread (thread fn)
458     (ext:interrupt-thread thread fn))
459    
460     (defimplementation kill-thread (thread)
461     (ext:destroy-thread thread))
462    
463     (defun mailbox (thread)
464     "Return THREAD's mailbox."
465 heller 1.6 (ext:with-thread-lock (*thread-props-lock*)
466     (or (getf (gethash thread *thread-props*) 'mailbox)
467     (setf (getf (gethash thread *thread-props*) 'mailbox)
468 asimon 1.5 (ext:make-mailbox)))))
469 heller 1.1
470 asimon 1.5 (defimplementation send (thread object)
471     (ext:mailbox-send (mailbox thread) object))
472 heller 1.1
473     (defimplementation receive ()
474 asimon 1.5 (ext:mailbox-read (mailbox (ext:current-thread))))
475 heller 1.1
476 asimon 1.29 ;;; Auto-flush streams
477    
478     ;; XXX race conditions
479     (defvar *auto-flush-streams* '())
480    
481     (defvar *auto-flush-thread* nil)
482    
483     (defimplementation make-stream-interactive (stream)
484     (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*))
485     (unless *auto-flush-thread*
486     (setq *auto-flush-thread*
487     (ext:make-thread #'flush-streams
488     :name "auto-flush-thread"))))
489    
490     (defun flush-streams ()
491     (loop
492     (setq *auto-flush-streams*
493     (remove-if (lambda (x)
494     (not (and (open-stream-p x)
495     (output-stream-p x))))
496     *auto-flush-streams*))
497     (mapc #'finish-output *auto-flush-streams*)
498     (sleep 0.15)))
499    
500 heller 1.1 (defimplementation quit-lisp ()
501     (ext:exit))
502 asimon 1.12

  ViewVC Help
Powered by ViewVC 1.1.5