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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5