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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.53 - (show annotations)
Sun Sep 12 23:56:39 2004 UTC (9 years, 7 months ago) by mbaringer
Branch: MAIN
Changes since 1.52: +65 -0 lines
2004-09-13  Marco Baringer  <mb@bese.it>

	* swank.lisp: New inspector protocol. The lisp side now returns a
	specially formated list of "things" to format which are then
	passed to emacs and rendered in the inspector buffer. Things can
	be either text, recursivly inspectable values, or functions to
	call.
	(inspected-parts): Redefine for new inspector protocol.
	(*inspectee-parts*): Redefine as array.
	(*inspectee-actions*): New array, similar to *inspectee-parts*.
	(reset-inspector): Update for new implementation of
	*inspectee-parts* and new variable *inspectee-actions*.
	(inspector-contents-for-emacs): New function.
	(inspect-object): Update for new inspector protocol.
	(inspector-nth-part): Update for new *inspectee-parts*
	implementation.
	(inspector-call-nth-action): New function.

	* slime.el (slime-inspector-action-face): New face.
	(slime-open-inspector): Adapt to new inspector protocol.
	(slime-inspector-operate-on-point): New function, subsumes
	slime-inspector-inspect-object-at-point.
	(slime-inspector-next-inspectable-object): Skip to next object,
	not just end of current object; wrap around buffer.
	(slime-inspector-mode-map): change bindings of [return] and "\C-m"

	* swank-bacend.lisp (swank-mop): New package. Simply defines all
	the MOP related symbols we need from an implementation.
	(arglist): Update doc string. Provide default implementation.
	(function-name): New backend function.

	* swank-allegro.lisp (swank-mop, slot-definition-documentation):
	Implement.

	* swank-sbcl.lisp (swank-mop, slot-definition-documentation,
	function-name): Implement.

	* swank-openmcl.lisp (swank-mop, function-name): Implement.
	(arglist): Implement for function objects.
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
2 ;;;
3 ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
4 ;;;
5 ;;; Created 2003, Helmut Eller
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
14 (eval-when (:compile-toplevel :load-toplevel :execute)
15 (require :sock)
16 (require :process)
17
18 (import
19 '(excl:fundamental-character-output-stream
20 excl:stream-write-char
21 excl:stream-force-output
22 excl:fundamental-character-input-stream
23 excl:stream-read-char
24 excl:stream-listen
25 excl:stream-unread-char
26 excl:stream-clear-input
27 excl:stream-line-column
28 excl:stream-read-char-no-hang)))
29
30 ;;; swank-mop
31
32 (eval-when (:compile-toplevel :load-toplevel :execute)
33 ;; Copied from swank-sbcl.lisp
34 ;; not sure if we still want a list of lists
35 ;; also not sure if we need to re-import too
36 (defun import-to-swank-mop (sym/sym-list)
37 (if (listp sym/sym-list)
38 (dolist (sym sym/sym-list)
39 (import-to-swank-mop sym))
40 (let* ((sym sym/sym-list)
41 (swank-mop-sym (find-symbol (symbol-name sym) :swank-mop)))
42 ;; 1) "delete" the symbol form the :swank-mop package
43 (when swank-mop-sym
44 (unintern swank-mop-sym :swank-mop))
45 (import sym :swank-mop)
46 (export sym :swank-mop))))
47
48 ;; maybe better change MOP to ACLMOP ?
49 (import-to-swank-mop
50 '( ;; classes
51 cl:standard-generic-function
52 mop::standard-slot-definition
53 cl:method
54 cl:standard-class
55 ;; standard-class readers
56 mop:class-default-initargs
57 mop:class-direct-default-initargs
58 mop:class-direct-slots
59 mop:class-direct-subclasses
60 mop:class-direct-superclasses
61 mop:class-finalized-p
62 cl:class-name
63 mop:class-precedence-list
64 mop:class-prototype
65 mop:class-slots
66 ;; generic function readers
67 mop:generic-function-argument-precedence-order
68 mop:generic-function-declarations
69 mop:generic-function-lambda-list
70 mop:generic-function-methods
71 mop:generic-function-method-class
72 mop:generic-function-method-combination
73 mop:generic-function-name
74 ;; method readers
75 mop:method-generic-function
76 mop:method-function
77 mop:method-lambda-list
78 mop:method-specializers
79 excl::method-qualifiers
80 ;; slot readers
81 mop:slot-definition-allocation
82 mop:slot-definition-initargs
83 mop:slot-definition-initform
84 mop:slot-definition-initfunction
85 mop:slot-definition-name
86 mop:slot-definition-type
87 mop:slot-definition-readers
88 mop:slot-definition-writers))
89
90 (defun swank-mop:slot-definition-documentation (slot)
91 (documentation slot))
92 )
93
94
95 ;;;; TCP Server
96
97 (defimplementation preferred-communication-style ()
98 :spawn)
99
100 (defimplementation create-socket (host port)
101 (socket:make-socket :connect :passive :local-port port
102 :local-host host :reuse-address t))
103
104 (defimplementation local-port (socket)
105 (socket:local-port socket))
106
107 (defimplementation close-socket (socket)
108 (close socket))
109
110 (defimplementation accept-connection (socket)
111 (socket:accept-connection socket :wait t))
112
113 (defimplementation format-sldb-condition (c)
114 (princ-to-string c))
115
116 (defimplementation condition-references (c)
117 (declare (ignore c))
118 '())
119
120 (defimplementation call-with-syntax-hooks (fn)
121 (funcall fn))
122
123 ;;;; Unix signals
124
125 (defimplementation call-without-interrupts (fn)
126 (excl:without-interrupts (funcall fn)))
127
128 (defimplementation getpid ()
129 (excl::getpid))
130
131 (defimplementation lisp-implementation-type-name ()
132 "allegro")
133
134 (defimplementation set-default-directory (directory)
135 (excl:chdir directory)
136 (namestring (setf *default-pathname-defaults*
137 (truename (merge-pathnames directory)))))
138
139 (defimplementation default-directory ()
140 (excl:chdir))
141
142 ;;;; Misc
143
144 (defimplementation arglist (symbol)
145 (handler-case (excl:arglist symbol)
146 (simple-error () :not-available)))
147
148 (defimplementation macroexpand-all (form)
149 (excl::walk form))
150
151 (defimplementation describe-symbol-for-emacs (symbol)
152 (let ((result '()))
153 (flet ((doc (kind &optional (sym symbol))
154 (or (documentation sym kind) :not-documented))
155 (maybe-push (property value)
156 (when value
157 (setf result (list* property value result)))))
158 (maybe-push
159 :variable (when (boundp symbol)
160 (doc 'variable)))
161 (maybe-push
162 :function (if (fboundp symbol)
163 (doc 'function)))
164 (maybe-push
165 :class (if (find-class symbol nil)
166 (doc 'class)))
167 result)))
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 make-stream-interactive (stream)
179 (setf (interactive-stream-p stream) t))
180
181 ;;;; Debugger
182
183 (defvar *sldb-topframe*)
184
185 (defimplementation call-with-debugging-environment (debugger-loop-fn)
186 (let ((*sldb-topframe* (excl::int-newest-frame))
187 (excl::*break-hook* nil))
188 (funcall debugger-loop-fn)))
189
190 (defun next-frame (frame)
191 (let ((next (excl::int-next-older-frame frame)))
192 (cond ((not next) nil)
193 ((debugger:frame-visible-p next) next)
194 (t (next-frame next)))))
195
196 (defun nth-frame (index)
197 (do ((frame *sldb-topframe* (next-frame frame))
198 (i index (1- i)))
199 ((zerop i) frame)))
200
201 (defimplementation compute-backtrace (start end)
202 (let ((end (or end most-positive-fixnum)))
203 (loop for f = (nth-frame start) then (next-frame f)
204 for i from start below end
205 while f
206 collect f)))
207
208 (defimplementation print-frame (frame stream)
209 (debugger:output-frame stream frame :moderate))
210
211 (defimplementation frame-locals (index)
212 (let ((frame (nth-frame index)))
213 (loop for i from 0 below (debugger:frame-number-vars frame)
214 collect (list :name (debugger:frame-var-name frame i)
215 :id 0
216 :value (debugger:frame-var-value frame i)))))
217
218 (defimplementation frame-var-value (frame var)
219 (let ((frame (nth-frame frame)))
220 (debugger:frame-var-value frame var)))
221
222 (defimplementation frame-catch-tags (index)
223 (declare (ignore index))
224 nil)
225
226 (defimplementation disassemble-frame (index)
227 (disassemble (debugger:frame-function (nth-frame index))))
228
229 (defimplementation frame-source-location-for-emacs (index)
230 (let* ((frame (nth-frame index))
231 (expr (debugger:frame-expression frame))
232 (fspec (first expr)))
233 (second (first (fspec-definition-locations fspec)))))
234
235 (defimplementation eval-in-frame (form frame-number)
236 (debugger:eval-form-in-context
237 form
238 (debugger:environment-of-frame (nth-frame frame-number))))
239
240 (defimplementation return-from-frame (frame-number form)
241 (let ((frame (nth-frame frame-number)))
242 (multiple-value-call #'debugger:frame-return
243 frame (debugger:eval-form-in-context
244 form
245 (debugger:environment-of-frame frame)))))
246
247 ;;; XXX doesn't work for frames with arguments
248 (defimplementation restart-frame (frame-number)
249 (let ((frame (nth-frame frame-number)))
250 (debugger:frame-retry frame (debugger:frame-function frame))))
251
252 ;;;; Compiler hooks
253
254 (defvar *buffer-name* nil)
255 (defvar *buffer-start-position*)
256 (defvar *buffer-string*)
257 (defvar *compile-filename* nil)
258
259 (defun handle-compiler-warning (condition)
260 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
261 (signal (make-condition
262 'compiler-condition
263 :original-condition condition
264 :severity :warning
265 :message (format nil "~A" condition)
266 :location (cond (*buffer-name*
267 (make-location
268 (list :buffer *buffer-name*)
269 (list :position *buffer-start-position*)))
270 (loc
271 (destructuring-bind (file . pos) loc
272 (make-location
273 (list :file (namestring (truename file)))
274 (list :position (1+ pos)))))
275 (*compile-filename*
276 (make-location
277 (list :file *compile-filename*)
278 (list :position 1)))
279 (t
280 (list :error "No error location available.")))))))
281
282 (defimplementation call-with-compilation-hooks (function)
283 (handler-bind ((warning #'handle-compiler-warning))
284 (funcall function)))
285
286 (defimplementation swank-compile-file (*compile-filename* load-p)
287 (with-compilation-hooks ()
288 (let ((*buffer-name* nil))
289 (compile-file *compile-filename* :load-after-compile load-p))))
290
291 (defun call-with-temp-file (fn)
292 (let ((tmpname (system:make-temp-file-name)))
293 (unwind-protect
294 (with-open-file (file tmpname :direction :output :if-exists :error)
295 (funcall fn file tmpname))
296 (delete-file tmpname))))
297
298 (defun compile-from-temp-file (string)
299 (call-with-temp-file
300 (lambda (stream filename)
301 (write-string string stream)
302 (finish-output stream)
303 (let ((binary-filename (compile-file filename :load-after-compile t)))
304 (when binary-filename
305 (delete-file binary-filename))))))
306
307 (defimplementation swank-compile-string (string &key buffer position directory)
308 ;; We store the source buffer in excl::*source-pathname* as a string
309 ;; of the form <buffername>;<start-offset>. Quite ugly encoding, but
310 ;; the fasl file is corrupted if we use some other datatype.
311 (with-compilation-hooks ()
312 (let ((*buffer-name* buffer)
313 (*buffer-start-position* position)
314 (*buffer-string* string)
315 (*default-pathname-defaults*
316 (if directory (merge-pathnames (pathname directory))
317 *default-pathname-defaults*)))
318 (compile-from-temp-file
319 (format nil "~S ~S~%~A"
320 `(in-package ,(package-name *package*))
321 `(eval-when (:compile-toplevel :load-toplevel)
322 (setq excl::*source-pathname*
323 ',(format nil "~A;~D" buffer position)))
324 string)))))
325
326 ;;;; Definition Finding
327
328 (defun fspec-primary-name (fspec)
329 (etypecase fspec
330 (symbol (string fspec))
331 (list (string (second fspec)))))
332
333 (defun find-fspec-location (fspec type)
334 (multiple-value-bind (file err) (ignore-errors (excl:source-file fspec type))
335 (etypecase file
336 (pathname
337 (let* ((start (scm:find-definition-in-file fspec type file))
338 (pos (if start
339 (list :position (1+ start))
340 (list :function-name (fspec-primary-name fspec)))))
341 (make-location (list :file (namestring (truename file)))
342 pos)))
343 ((member :top-level)
344 (list :error (format nil "Defined at toplevel: ~A"
345 (fspec->string fspec))))
346 (string
347 (let ((pos (position #\; file :from-end t)))
348 (make-location
349 (list :buffer (subseq file 0 pos))
350 (list :position (parse-integer (subseq file (1+ pos)))))))
351 (null
352 (list :error (if err
353 (princ-to-string err)
354 (format nil "Unknown source location for ~A"
355 (fspec->string fspec))))))))
356
357 (defun fspec->string (fspec)
358 (etypecase fspec
359 (symbol (let ((*package* (find-package :keyword)))
360 (prin1-to-string fspec)))
361 (list (format nil "(~A ~A)"
362 (prin1-to-string (first fspec))
363 (let ((*package* (find-package :keyword)))
364 (prin1-to-string (second fspec)))))))
365
366 (defun fspec-definition-locations (fspec)
367 (let ((defs (excl::find-multiple-definitions fspec)))
368 (loop for (fspec type) in defs
369 collect (list (list type fspec)
370 (find-fspec-location fspec type)))))
371
372 (defimplementation find-definitions (symbol)
373 (fspec-definition-locations symbol))
374
375 ;;;; XREF
376
377 (defmacro defxref (name relation name1 name2)
378 `(defimplementation ,name (x)
379 (xref-result (xref:get-relation ,relation ,name1 ,name2))))
380
381 (defxref who-calls :calls :wild x)
382 (defxref who-references :uses :wild x)
383 (defxref who-binds :binds :wild x)
384 (defxref who-macroexpands :macro-calls :wild x)
385 (defxref who-sets :sets :wild x)
386 (defxref list-callees :calls x :wild)
387
388 (defun xref-result (fspecs)
389 (loop for fspec in fspecs
390 append (fspec-definition-locations fspec)))
391
392 ;; list-callers implemented by groveling through all fbound symbols.
393 ;; Only symbols are considered. Functions in the constant pool are
394 ;; searched recursevly. Closure environments are ignored at the
395 ;; moment (constants in methods are therefore not found).
396
397 (defun map-function-constants (function fn depth)
398 "Call FN with the elements of FUNCTION's constant pool."
399 (do ((i 0 (1+ i))
400 (max (excl::function-constant-count function)))
401 ((= i max))
402 (let ((c (excl::function-constant function i)))
403 (cond ((and (functionp c)
404 (not (eq c function))
405 (plusp depth))
406 (map-function-constants c fn (1- depth)))
407 (t
408 (funcall fn c))))))
409
410 (defun in-constants-p (fn symbol)
411 (map-function-constants
412 fn
413 (lambda (c) (if (eq c symbol) (return-from in-constants-p t)))
414 3))
415
416 (defun function-callers (name)
417 (let ((callers '()))
418 (do-all-symbols (sym)
419 (when (fboundp sym)
420 (let ((fn (fdefinition sym)))
421 (when (in-constants-p fn name)
422 (push sym callers)))))
423 callers))
424
425 (defimplementation list-callers (name)
426 (xref-result (function-callers name)))
427
428 ;;;; Inspecting
429
430 (defmethod inspected-parts (o)
431 (let* ((class (class-of o))
432 (slots (clos:class-slots class)))
433 (values (format nil "~A~% is a ~A" o class)
434 (mapcar (lambda (slot)
435 (let ((name (clos:slot-definition-name slot)))
436 (cons (princ-to-string name)
437 (if (slot-boundp o name)
438 (slot-value o name)
439 (make-unbound-slot-filler)))))
440 slots))))
441
442 ;;;; Multithreading
443
444 (defimplementation startup-multiprocessing ()
445 (mp:start-scheduler))
446
447 (defimplementation spawn (fn &key name)
448 (mp:process-run-function name fn))
449
450 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
451 (defvar *thread-id-counter* 0)
452
453 (defimplementation thread-id (thread)
454 (mp:with-process-lock (*id-lock*)
455 (or (getf (mp:process-property-list thread) 'id)
456 (setf (getf (mp:process-property-list thread) 'id)
457 (incf *thread-id-counter*)))))
458
459 (defimplementation find-thread (id)
460 (find id mp:*all-processes*
461 :key (lambda (p) (getf (mp:process-property-list p) 'id))))
462
463 (defimplementation thread-name (thread)
464 (mp:process-name thread))
465
466 (defimplementation thread-status (thread)
467 (format nil "~A ~D" (mp:process-whostate thread)
468 (mp:process-priority thread)))
469
470 (defimplementation make-lock (&key name)
471 (mp:make-process-lock :name name))
472
473 (defimplementation call-with-lock-held (lock function)
474 (mp:with-process-lock (lock) (funcall function)))
475
476 (defimplementation current-thread ()
477 mp:*current-process*)
478
479 (defimplementation all-threads ()
480 (copy-list mp:*all-processes*))
481
482 (defimplementation interrupt-thread (thread fn)
483 (mp:process-interrupt thread fn))
484
485 (defimplementation kill-thread (thread)
486 (mp:process-kill thread))
487
488 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
489
490 (defstruct (mailbox (:conc-name mailbox.))
491 (mutex (mp:make-process-lock :name "process mailbox"))
492 (queue '() :type list))
493
494 (defun mailbox (thread)
495 "Return THREAD's mailbox."
496 (mp:with-process-lock (*mailbox-lock*)
497 (or (getf (mp:process-property-list thread) 'mailbox)
498 (setf (getf (mp:process-property-list thread) 'mailbox)
499 (make-mailbox)))))
500
501 (defimplementation send (thread message)
502 (let* ((mbox (mailbox thread))
503 (mutex (mailbox.mutex mbox)))
504 (mp:process-wait-with-timeout
505 "yielding before sending" 0.1
506 (lambda ()
507 (mp:with-process-lock (mutex)
508 (< (length (mailbox.queue mbox)) 10))))
509 (mp:with-process-lock (mutex)
510 (setf (mailbox.queue mbox)
511 (nconc (mailbox.queue mbox) (list message))))))
512
513 (defimplementation receive ()
514 (let* ((mbox (mailbox mp:*current-process*))
515 (mutex (mailbox.mutex mbox)))
516 (mp:process-wait "receive" #'mailbox.queue mbox)
517 (mp:with-process-lock (mutex)
518 (pop (mailbox.queue mbox)))))
519
520 (defimplementation quit-lisp ()
521 (excl:exit 0 :quiet t))

  ViewVC Help
Powered by ViewVC 1.1.5