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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Sun Jun 27 17:10:33 2004 UTC (9 years, 9 months ago) by asimon
Branch: MAIN
Changes since 1.6: +1 -1 lines
find-thread: :test => :key
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     ;;; Created 2004, Andras Simon
6     ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8     ;;; are disclaimed. This code was written for "Allegro CL Trial
9     ;;; Edition "5.0 [Linux/X86] (8/29/98 10:57)".
10     ;;;
11    
12     (in-package :swank-backend)
13     (use-package :java)
14    
15    
16    
17     (eval-when (:compile-toplevel :load-toplevel :execute)
18     (require :collect) ;just so that it doesn't spoil the flying letters
19     (require :gray-streams)
20     (require :pprint)
21     )
22    
23     (import
24     '(gs:fundamental-character-output-stream
25     gs:stream-write-char
26     gs:stream-force-output
27     gs:fundamental-character-input-stream
28     gs:stream-read-char
29     gs:stream-listen
30     gs:stream-unread-char
31     gs:stream-clear-input
32     gs:stream-line-column
33     gs:stream-read-char-no-hang
34     ))
35    
36     ;;;; TCP Server
37    
38    
39     (defimplementation preferred-communication-style ()
40     :spawn)
41    
42    
43    
44     (defimplementation create-socket (host port)
45     (ext:make-server-socket port))
46    
47    
48     (defimplementation local-port (socket)
49     (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
50    
51    
52     (defimplementation close-socket (socket)
53     (ext:server-socket-close socket))
54    
55    
56     (defimplementation accept-connection (socket)
57     (ext:get-socket-stream (ext:socket-accept socket)))
58    
59 heller 1.3 (defimplementation emacs-connected (stream)
60     (declare (ignore stream)))
61 heller 1.1
62     ;;;; Unix signals
63    
64     (defimplementation call-without-interrupts (fn)
65     (funcall fn))
66    
67     ;;there are too many to count
68     (defimplementation getpid ()
69     0)
70    
71     (defimplementation lisp-implementation-type-name ()
72     "armedbear")
73    
74     (defimplementation set-default-directory (directory)
75     (let ((dir (sys::probe-directory directory)))
76     (when dir (setf *default-pathname-defaults* dir))
77     (namestring dir)))
78    
79    
80     ;;;; Misc
81    
82     (defimplementation arglist (symbol)
83     (handler-case (sys::arglist symbol)
84     (simple-error () :not-available)))
85    
86     (defimplementation macroexpand-all (form)
87     (macroexpand form))
88    
89     (defimplementation describe-symbol-for-emacs (symbol)
90     (let ((result '()))
91     (flet ((doc (kind &optional (sym symbol))
92     (or (documentation sym kind) :not-documented))
93     (maybe-push (property value)
94     (when value
95     (setf result (list* property value result)))))
96     (maybe-push
97     :variable (when (boundp symbol)
98     (doc 'variable)))
99     (maybe-push
100     :function (if (fboundp symbol)
101     (doc 'function)))
102     (maybe-push
103     :class (if (find-class symbol nil)
104     (doc 'class)))
105     result)))
106    
107    
108     (defimplementation describe-definition (symbol namespace)
109     (ecase namespace
110     (:variable
111     (describe symbol))
112     ((:function :generic-function)
113     (describe (symbol-function symbol)))
114     (:class
115     (describe (find-class symbol)))))
116    
117     (defimplementation describe-definition (symbol namespace)
118     (ecase namespace
119     (:variable
120     (describe symbol))
121     ((:function :generic-function)
122     (describe (symbol-function symbol)))
123     (:class
124     (describe (find-class symbol)))))
125    
126    
127     ;;;; Debugger
128    
129     (defvar *sldb-topframe*)
130    
131     (defimplementation call-with-debugging-environment (debugger-loop-fn)
132     (let ((*sldb-topframe* (car (ext:backtrace-as-list)) #+nil (excl::int-newest-frame)))
133     (funcall debugger-loop-fn)))
134    
135     (defun nth-frame (index)
136     (nth index (ext:backtrace-as-list)))
137    
138     (defimplementation compute-backtrace (start end)
139     (let ((end (or end most-positive-fixnum)))
140     (subseq (ext:backtrace-as-list) start end)))
141    
142     (defimplementation print-frame (frame stream)
143     (print frame stream))
144    
145     #+nil
146     (defimplementation frame-locals (index)
147     (let ((frame (nth-frame index)))
148     (loop for i from 0 below (debugger:frame-number-vars frame)
149     collect (list :name (debugger:frame-var-name frame i)
150     :id 0
151     :value (debugger:frame-var-value frame i)))))
152    
153     (defimplementation frame-catch-tags (index)
154     (declare (ignore index))
155     nil)
156    
157     #+nil
158     (defimplementation disassemble-frame (index)
159     (disassemble (debugger:frame-function (nth-frame index))))
160    
161     (defimplementation frame-source-location-for-emacs (index)
162     (list :error (format nil "Cannot find source for frame: ~A"
163     (nth-frame index))))
164    
165     #+nil
166     (defimplementation eval-in-frame (form frame-number)
167     (debugger:eval-form-in-context
168     form
169     (debugger:environment-of-frame (nth-frame frame-number))))
170    
171     #+nil
172     (defimplementation return-from-frame (frame-number form)
173     (let ((frame (nth-frame frame-number)))
174     (multiple-value-call #'debugger:frame-return
175     frame (debugger:eval-form-in-context
176     form
177     (debugger:environment-of-frame frame)))))
178    
179     ;;; XXX doesn't work for frames with arguments
180     #+nil
181     (defimplementation restart-frame (frame-number)
182     (let ((frame (nth-frame frame-number)))
183     (debugger:frame-retry frame (debugger:frame-function frame))))
184    
185     ;;;; Compiler hooks
186    
187     (defvar *buffer-name* nil)
188     (defvar *buffer-start-position*)
189     (defvar *buffer-string*)
190     (defvar *compile-filename*)
191    
192     (defun handle-compiler-warning (condition)
193     #+nil
194     (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
195     (signal (make-condition
196     'compiler-condition
197     :original-condition condition
198     :severity :warning
199     :message (format nil "~A" condition)
200     :location (cond (*buffer-name*
201     (make-location
202     (list :buffer *buffer-name*)
203     (list :position *buffer-start-position*)))
204     (loc
205     (destructuring-bind (file . pos) loc
206     (make-location
207     (list :file (namestring (truename file)))
208     (list :position (1+ pos)))))
209     (t
210     (make-location
211     (list :file *compile-filename*)
212     (list :position 1))))))))
213    
214     (defimplementation swank-compile-file (*compile-filename* load-p)
215     (handler-bind ((warning #'handle-compiler-warning))
216     (let ((*buffer-name* nil))
217     (multiple-value-bind (fn warn fail)
218     (compile-file *compile-filename*)
219     (when load-p (unless fail (load fn)))))))
220    
221     (defimplementation swank-compile-string (string &key buffer position)
222     (handler-bind ((warning #'handle-compiler-warning))
223     (let ((*buffer-name* buffer)
224     (*buffer-start-position* position)
225     (*buffer-string* string))
226     (funcall (compile nil (read-from-string
227     (format nil "(~S () ~A)" 'lambda string)))))))
228    
229     #|
230     ;;;; Definition Finding
231    
232     (defun find-fspec-location (fspec type)
233     (let ((file (excl::fspec-pathname fspec type)))
234     (etypecase file
235     (pathname
236     (let ((start (scm:find-definition-in-file fspec type file)))
237     (make-location (list :file (namestring (truename file)))
238     (if start
239     (list :position (1+ start))
240     (list :function-name (string fspec))))))
241     ((member :top-level)
242     (list :error (format nil "Defined at toplevel: ~A" fspec)))
243     (null
244     (list :error (format nil "Unkown source location for ~A" fspec))))))
245    
246     (defun fspec-definition-locations (fspec)
247     (let ((defs (excl::find-multiple-definitions fspec)))
248     (loop for (fspec type) in defs
249     collect (list fspec (find-fspec-location fspec type)))))
250    
251     (defimplementation find-definitions (symbol)
252     (fspec-definition-locations symbol))
253    
254     |#
255    
256 asimon 1.2 (defun source-location (symbol)
257     (when (ext:source symbol)
258     `(((,symbol)
259     (:location
260     (:file ,(namestring (ext:source-pathname symbol)))
261     (:position ,(ext:source-file-position symbol) t)
262     (:snippet nil))))))
263    
264    
265     (defimplementation find-definitions (symbol)
266     (source-location symbol))
267    
268    
269 heller 1.1 #|
270     Should work (with a patched xref.lisp) but is it any use without find-definitions?
271     ;;;; XREF
272     (setq pxref::*handle-package-forms* '(cl:in-package))
273    
274     (defmacro defxref (name function)
275     `(defimplementation ,name (name)
276     (xref-results (,function name))))
277    
278     (defxref who-calls pxref:list-callers)
279     (defxref who-references pxref:list-readers)
280     (defxref who-binds pxref:list-setters)
281     (defxref who-sets pxref:list-setters)
282     (defxref list-callers pxref:list-callers)
283     (defxref list-callees pxref:list-callees)
284    
285     (defun xref-results (symbols)
286     (let ((xrefs '()))
287     (dolist (symbol symbols)
288     (push (list symbol (fspec-location symbol)) xrefs))
289     xrefs))
290    
291     |#
292    
293     #|
294    
295     ;;;; Inspecting
296    
297     (defmethod inspected-parts (o)
298     (let* ((class (class-of o))
299     (slots (clos:class-slots class)))
300     (values (format nil "~A~% is a ~A" o class)
301     (mapcar (lambda (slot)
302     (let ((name (clos:slot-definition-name slot)))
303     (cons (princ-to-string name)
304     (slot-value o name))))
305     slots))))
306     |#
307     ;;;; Multithreading
308    
309     (defimplementation startup-multiprocessing ()
310     #+nil(mp:start-scheduler))
311    
312     (defimplementation spawn (fn &key name)
313     (ext:make-thread (lambda () (funcall fn))))
314    
315 heller 1.6 (defvar *thread-props-lock* (ext:make-thread-lock))
316    
317     (defvar *thread-props* (make-hash-table) ; should be a weak table
318     "A hashtable mapping threads to a plist.")
319    
320     (defvar *thread-id-counter* 0)
321    
322     (defimplementation thread-id (thread)
323     (ext:with-thread-lock (*thread-props-lock*)
324     (or (getf (gethash thread *thread-props*) 'id)
325     (setf (getf (gethash thread *thread-props*) 'id)
326     (incf *thread-id-counter*)))))
327    
328     (defimplementation find-thread (id)
329     (find id (all-threads)
330 asimon 1.7 :key (lambda (thread)
331 heller 1.6 (getf (gethash thread *thread-props*) 'id))))
332    
333 heller 1.1 (defimplementation thread-name (thread)
334 asimon 1.4 (princ-to-string thread))
335 heller 1.1
336     (defimplementation thread-status (thread)
337 asimon 1.4 (format nil "Thread is ~:[dead~;alive~]" (ext:thread-alive-p thread)))
338 heller 1.1
339     (defimplementation make-lock (&key name)
340     (ext:make-thread-lock))
341    
342     (defimplementation call-with-lock-held (lock function)
343     (ext:with-thread-lock (lock) (funcall function)))
344    
345     (defimplementation current-thread ()
346     (ext:current-thread))
347    
348     (defimplementation all-threads ()
349     (copy-list (ext:mapcar-threads #'identity)))
350    
351     (defimplementation interrupt-thread (thread fn)
352     (ext:interrupt-thread thread fn))
353    
354     (defimplementation kill-thread (thread)
355     (ext:destroy-thread thread))
356    
357     (defun mailbox (thread)
358     "Return THREAD's mailbox."
359 heller 1.6 (ext:with-thread-lock (*thread-props-lock*)
360     (or (getf (gethash thread *thread-props*) 'mailbox)
361     (setf (getf (gethash thread *thread-props*) 'mailbox)
362 asimon 1.5 (ext:make-mailbox)))))
363 heller 1.1
364 asimon 1.5 (defimplementation send (thread object)
365     (ext:mailbox-send (mailbox thread) object))
366 heller 1.1
367     (defimplementation receive ()
368 asimon 1.5 (ext:mailbox-read (mailbox (ext:current-thread))))
369 heller 1.1
370     (defimplementation quit-lisp ()
371     (ext:exit))

  ViewVC Help
Powered by ViewVC 1.1.5