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

Contents of /slime/swank-ccl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Fri Mar 5 17:45:26 2010 UTC (4 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.16: +34 -37 lines
* swank-ccl.lisp: Indentation fixes.
1 ;;;; -*- indent-tabs-mode: nil -*-
2 ;;;
3 ;;; swank-ccl.lisp --- SLIME backend for Clozure CL.
4 ;;;
5 ;;; Copyright (C) 2003, James Bielman <jamesjb@jamesjb.com>
6 ;;;
7 ;;; This program is licensed under the terms of the Lisp Lesser GNU
8 ;;; Public License, known as the LLGPL, and distributed with Clozure CL
9 ;;; as the file "LICENSE". The LLGPL consists of a preamble and the
10 ;;; LGPL, which is distributed with Clozure CL as the file "LGPL". Where
11 ;;; these conflict, the preamble takes precedence.
12 ;;;
13 ;;; The LLGPL is also available online at
14 ;;; http://opensource.franz.com/preamble.html
15
16 (in-package :swank-backend)
17
18 (eval-when (:compile-toplevel :execute :load-toplevel)
19 (assert (and (= ccl::*openmcl-major-version* 1)
20 (>= ccl::*openmcl-minor-version* 4))
21 () "This file needs CCL version 1.4 or newer"))
22
23 (import-from :ccl *gray-stream-symbols* :swank-backend)
24
25 (eval-when (:compile-toplevel :load-toplevel :execute)
26 (require 'xref))
27
28 ;;; swank-mop
29
30 (import-to-swank-mop
31 '( ;; classes
32 cl:standard-generic-function
33 ccl:standard-slot-definition
34 cl:method
35 cl:standard-class
36 ccl:eql-specializer
37 openmcl-mop:finalize-inheritance
38 openmcl-mop:compute-applicable-methods-using-classes
39 ;; standard-class readers
40 openmcl-mop:class-default-initargs
41 openmcl-mop:class-direct-default-initargs
42 openmcl-mop:class-direct-slots
43 openmcl-mop:class-direct-subclasses
44 openmcl-mop:class-direct-superclasses
45 openmcl-mop:class-finalized-p
46 cl:class-name
47 openmcl-mop:class-precedence-list
48 openmcl-mop:class-prototype
49 openmcl-mop:class-slots
50 openmcl-mop:specializer-direct-methods
51 ;; eql-specializer accessors
52 openmcl-mop:eql-specializer-object
53 ;; generic function readers
54 openmcl-mop:generic-function-argument-precedence-order
55 openmcl-mop:generic-function-declarations
56 openmcl-mop:generic-function-lambda-list
57 openmcl-mop:generic-function-methods
58 openmcl-mop:generic-function-method-class
59 openmcl-mop:generic-function-method-combination
60 openmcl-mop:generic-function-name
61 ;; method readers
62 openmcl-mop:method-generic-function
63 openmcl-mop:method-function
64 openmcl-mop:method-lambda-list
65 openmcl-mop:method-specializers
66 openmcl-mop:method-qualifiers
67 ;; slot readers
68 openmcl-mop:slot-definition-allocation
69 openmcl-mop:slot-definition-documentation
70 openmcl-mop:slot-value-using-class
71 openmcl-mop:slot-definition-initargs
72 openmcl-mop:slot-definition-initform
73 openmcl-mop:slot-definition-initfunction
74 openmcl-mop:slot-definition-name
75 openmcl-mop:slot-definition-type
76 openmcl-mop:slot-definition-readers
77 openmcl-mop:slot-definition-writers
78 openmcl-mop:slot-boundp-using-class
79 openmcl-mop:slot-makunbound-using-class))
80
81 (defmacro swank-sym (sym)
82 (let ((str (symbol-name sym)))
83 `(or (find-symbol ,str :swank)
84 (error "There is no symbol named ~a in the SWANK package" ,str))))
85
86 ;;; TCP Server
87
88 (defimplementation preferred-communication-style ()
89 :spawn)
90
91 (defimplementation create-socket (host port)
92 (ccl:make-socket :connect :passive :local-port port
93 :local-host host :reuse-address t))
94
95 (defimplementation local-port (socket)
96 (ccl:local-port socket))
97
98 (defimplementation close-socket (socket)
99 (close socket))
100
101 (defimplementation accept-connection (socket &key external-format
102 buffering timeout)
103 (declare (ignore buffering timeout))
104 (let ((stream-args (and external-format
105 `(:external-format ,external-format))))
106 (ccl:accept-connection socket :wait t :stream-args stream-args)))
107
108 (defvar *external-format-to-coding-system*
109 '((:iso-8859-1
110 "latin-1" "latin-1-unix" "iso-latin-1-unix"
111 "iso-8859-1" "iso-8859-1-unix")
112 (:utf-8 "utf-8" "utf-8-unix")))
113
114 (defimplementation find-external-format (coding-system)
115 (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
116 *external-format-to-coding-system*)))
117
118 ;;; Unix signals
119
120 (defimplementation getpid ()
121 (ccl::getpid))
122
123 (defimplementation lisp-implementation-type-name ()
124 "ccl")
125
126 ;;; Arglist
127
128 (defimplementation arglist (fname)
129 (multiple-value-bind (arglist binding) (let ((*break-on-signals* nil))
130 (ccl:arglist fname))
131 (if binding
132 arglist
133 :not-available)))
134
135 (defimplementation function-name (function)
136 (ccl:function-name function))
137
138 (defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
139 (let ((flags (ccl:declaration-information decl-identifier)))
140 (if flags
141 `(&any ,flags)
142 (call-next-method))))
143
144 ;;; Compilation
145
146 (defun handle-compiler-warning (condition)
147 "Resignal a ccl:compiler-warning as swank-backend:compiler-warning."
148 (signal (make-condition
149 'compiler-condition
150 :original-condition condition
151 :message (compiler-warning-short-message condition)
152 :source-context nil
153 :severity (compiler-warning-severity condition)
154 :location (source-note-to-source-location
155 (ccl:compiler-warning-source-note condition)
156 (lambda () "Unknown source")
157 (ccl:compiler-warning-function-name condition)))))
158
159 (defgeneric compiler-warning-severity (condition))
160 (defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning)
161 (defmethod compiler-warning-severity ((c ccl:style-warning)) :style-warning)
162
163 (defgeneric compiler-warning-short-message (condition))
164
165 ;; Pretty much the same as ccl:report-compiler-warning but
166 ;; without the source position and function name stuff.
167 (defmethod compiler-warning-short-message ((c ccl:compiler-warning))
168 (with-output-to-string (stream)
169 (ccl:report-compiler-warning c stream :short t)))
170
171 (defimplementation call-with-compilation-hooks (function)
172 (handler-bind ((ccl:compiler-warning 'handle-compiler-warning))
173 (let ((ccl:*merge-compiler-warnings* nil))
174 (funcall function))))
175
176 (defimplementation swank-compile-file (input-file output-file
177 load-p external-format
178 &key policy)
179 (declare (ignore policy))
180 (with-compilation-hooks ()
181 (compile-file input-file
182 :output-file output-file
183 :load load-p
184 :external-format external-format)))
185
186 ;; Use a temp file rather than in-core compilation in order to handle
187 ;; eval-when's as compile-time.
188 (defimplementation swank-compile-string (string &key buffer position filename
189 policy)
190 (declare (ignore policy))
191 (with-compilation-hooks ()
192 (let ((temp-file-name (ccl:temp-pathname))
193 (ccl:*save-source-locations* t))
194 (unwind-protect
195 (progn
196 (with-open-file (s temp-file-name :direction :output
197 :if-exists :error)
198 (write-string string s))
199 (let ((binary-filename (compile-temp-file
200 temp-file-name filename buffer position)))
201 (delete-file binary-filename)))
202 (delete-file temp-file-name)))))
203
204 (defvar *temp-file-map* (make-hash-table :test #'equal)
205 "A mapping from tempfile names to Emacs buffer names.")
206
207 (defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset)
208 (compile-file temp-file-name
209 :load t
210 :compile-file-original-truename
211 (or buffer-file-name
212 (progn
213 (setf (gethash temp-file-name *temp-file-map*)
214 buffer-name)
215 temp-file-name))
216 :compile-file-original-buffer-offset (1- offset)))
217
218 (defimplementation save-image (filename &optional restart-function)
219 (ccl:save-application filename :toplevel-function restart-function))
220
221 ;;; Cross-referencing
222
223 (defun xref-locations (relation name &optional inverse)
224 (delete-duplicates
225 (mapcan #'find-definitions
226 (if inverse
227 (ccl:get-relation relation name :wild :exhaustive t)
228 (ccl:get-relation relation :wild name :exhaustive t)))
229 :test 'equal))
230
231 (defimplementation who-binds (name)
232 (xref-locations :binds name))
233
234 (defimplementation who-macroexpands (name)
235 (xref-locations :macro-calls name t))
236
237 (defimplementation who-references (name)
238 (remove-duplicates
239 (append (xref-locations :references name)
240 (xref-locations :sets name)
241 (xref-locations :binds name))
242 :test 'equal))
243
244 (defimplementation who-sets (name)
245 (xref-locations :sets name))
246
247 (defimplementation who-calls (name)
248 (remove-duplicates
249 (append
250 (xref-locations :direct-calls name)
251 (xref-locations :indirect-calls name)
252 (xref-locations :macro-calls name t))
253 :test 'equal))
254
255 (defimplementation who-specializes (class)
256 (when (symbolp class)
257 (setq class (find-class class nil)))
258 (when class
259 (delete-duplicates
260 (mapcar (lambda (m)
261 (car (find-definitions m)))
262 (ccl:specializer-direct-methods class))
263 :test 'equal)))
264
265 (defimplementation list-callees (name)
266 (remove-duplicates
267 (append
268 (xref-locations :direct-calls name t)
269 (xref-locations :macro-calls name nil))
270 :test 'equal))
271
272 (defimplementation list-callers (symbol)
273 (delete-duplicates
274 (mapcan #'find-definitions (ccl:caller-functions symbol))
275 :test #'equal))
276
277 ;;; Profiling (alanr: lifted from swank-clisp)
278
279 (defimplementation profile (fname)
280 (eval `(mon:monitor ,fname))) ;monitor is a macro
281
282 (defimplementation profiled-functions ()
283 mon:*monitored-functions*)
284
285 (defimplementation unprofile (fname)
286 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
287
288 (defimplementation unprofile-all ()
289 (mon:unmonitor))
290
291 (defimplementation profile-report ()
292 (mon:report-monitoring))
293
294 (defimplementation profile-reset ()
295 (mon:reset-all-monitoring))
296
297 (defimplementation profile-package (package callers-p methods)
298 (declare (ignore callers-p methods))
299 (mon:monitor-all package))
300
301 ;;; Debugging
302
303 (defun openmcl-set-debug-switches ()
304 (setq ccl:*fasl-save-definitions* nil)
305 (setq ccl:*fasl-save-doc-strings* t)
306 (setq ccl:*fasl-save-local-symbols* t)
307 (setq ccl:*save-arglist-info* t)
308 (setq ccl:*save-definitions* nil)
309 (setq ccl:*save-doc-strings* t)
310 (setq ccl:*save-local-symbols* t)
311 (ccl:start-xref))
312
313 (defimplementation call-with-debugging-environment (debugger-loop-fn)
314 (let* (;;(*debugger-hook* nil)
315 ;; don't let error while printing error take us down
316 (ccl:*signal-printing-errors* nil))
317 (funcall debugger-loop-fn)))
318
319 ;; This is called for an async interrupt and is running in a random
320 ;; thread not selected by the user, so don't use thread-local vars
321 ;; such as *emacs-connection*.
322 (defun find-repl-thread ()
323 (let* ((conn (funcall (swank-sym default-connection))))
324 (and conn
325 (let ((*break-on-signals* nil))
326 (ignore-errors ;; this errors if no repl-thread
327 (funcall (swank-sym repl-thread) conn))))))
328
329 (defimplementation call-with-debugger-hook (hook fun)
330 (let ((*debugger-hook* hook)
331 (ccl:*break-hook* hook)
332 (ccl:*select-interactive-process-hook* 'find-repl-thread))
333 (funcall fun)))
334
335 (defimplementation install-debugger-globally (function)
336 (setq *debugger-hook* function)
337 (setq ccl:*break-hook* function)
338 (setq ccl:*select-interactive-process-hook* 'find-repl-thread)
339 )
340
341 (defun map-backtrace (function &optional
342 (start-frame-number 0)
343 end-frame-number)
344 "Call FUNCTION passing information about each stack frame
345 from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
346 (let ((end-frame-number (or end-frame-number most-positive-fixnum)))
347 (ccl:map-call-frames function
348 :origin ccl:*top-error-frame*
349 :start-frame-number start-frame-number
350 :count (- end-frame-number start-frame-number)
351 :test (and (not t) ;(not (symbol-value (swank-sym *sldb-show-internal-frames*)))
352 'interesting-frame-p))))
353
354 ;; Exceptions
355 (defvar *interesting-internal-frames* ())
356
357 (defun interesting-frame-p (p context)
358 ;; A frame is interesting if it has at least one external symbol in its name.
359 (labels ((internal (obj)
360 ;; For a symbol, return true if the symbol is internal, i.e. not
361 ;; declared to be external. For a cons or list, everything
362 ;; must be internal. For a method, the name must be internal.
363 ;; Nothing else is internal.
364 (typecase obj
365 (cons (and (internal (car obj)) (internal (cdr obj))))
366 (symbol (and (eq (symbol-package obj) (find-package :ccl))
367 (eq :internal (nth-value 1 (find-symbol (symbol-name obj) :ccl)))
368 (not (member obj *interesting-internal-frames*))))
369 (method (internal (ccl:method-name obj)))
370 (t nil))))
371 (let* ((lfun (ccl:frame-function p context))
372 (internal-frame-p (internal (ccl:function-name lfun))))
373 #+debug (format t "~S is ~@[not ~]internal~%"
374 (ccl:function-name lfun)
375 (not internal-frame-p))
376 (not internal-frame-p))))
377
378
379 (defimplementation compute-backtrace (start-frame-number end-frame-number)
380 (let (result)
381 (map-backtrace (lambda (p context)
382 (push (list :frame p context) result))
383 start-frame-number end-frame-number)
384 (nreverse result)))
385
386 (defimplementation print-frame (frame stream)
387 (assert (eq (first frame) :frame))
388 (destructuring-bind (p context) (rest frame)
389 (let ((lfun (ccl:frame-function p context)))
390 (format stream "(~S" (or (ccl:function-name lfun) lfun))
391 (let* ((unavailable (cons nil nil))
392 (args (ccl:frame-supplied-arguments p context
393 :unknown-marker unavailable)))
394 (declare (dynamic-extent unavailable))
395 (if (eq args unavailable)
396 (format stream " #<Unknown Arguments>")
397 (dolist (arg args)
398 (if (eq arg unavailable)
399 (format stream " #<Unavailable>")
400 (format stream " ~s" arg)))))
401 (format stream ")"))))
402
403 (defmacro with-frame ((p context) frame-number &body body)
404 `(call/frame ,frame-number (lambda (,p ,context) . ,body)))
405
406 (defun call/frame (frame-number if-found)
407 (map-backtrace
408 (lambda (p context)
409 (return-from call/frame
410 (funcall if-found p context)))
411 frame-number))
412
413 (defimplementation frame-call (frame-number)
414 (with-frame (p context) frame-number
415 (with-output-to-string (stream)
416 (print-frame (list :frame p context) stream))))
417
418 (defimplementation frame-var-value (frame var)
419 (with-frame (p context) frame
420 (cdr (nth var (ccl:frame-named-variables p context)))))
421
422 (defimplementation frame-locals (index)
423 (with-frame (p context) index
424 (loop for (name . value) in (ccl:frame-named-variables p context)
425 collect (list :name name :value value :id 0))))
426
427 (defimplementation frame-source-location (index)
428 (with-frame (p context) index
429 (multiple-value-bind (lfun pc) (ccl:frame-function p context)
430 (if pc
431 (pc-source-location lfun pc)
432 (function-source-location lfun)))))
433
434 (defimplementation eval-in-frame (form index)
435 (with-frame (p context) index
436 (let ((vars (ccl:frame-named-variables p context)))
437 (eval `(let ,(loop for (var . val) in vars collect `(,var ',val))
438 (declare (ignorable ,@(mapcar #'car vars)))
439 ,form)))))
440
441 (defimplementation return-from-frame (index form)
442 (let ((values (multiple-value-list (eval-in-frame form index))))
443 (with-frame (p context) index
444 (declare (ignore context))
445 (ccl:apply-in-frame p #'values values))))
446
447 (defimplementation restart-frame (index)
448 (with-frame (p context) index
449 (ccl:apply-in-frame p
450 (ccl:frame-function p context)
451 (ccl:frame-supplied-arguments p context))))
452
453 (defimplementation disassemble-frame (the-frame-number)
454 (with-frame (p context) the-frame-number
455 (multiple-value-bind (lfun pc) (ccl:frame-function p context)
456 (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context)
457 (disassemble lfun))))
458
459 ;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008)
460 ;; contains some interesting details:
461 ;;
462 ;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects
463 ;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS,
464 ;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end
465 ;; positions are file positions (not character positions). The text will
466 ;; be NIL unless text recording was on at read-time. If the original
467 ;; file is still available, you can force missing source text to be read
468 ;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.
469 ;;
470 ;; Source-note's are associated with definitions (via record-source-file)
471 ;; and also stored in function objects (including anonymous and nested
472 ;; functions). The former can be retrieved via
473 ;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.
474 ;;
475 ;; The recording behavior is controlled by the new variable
476 ;; CCL:*SAVE-SOURCE-LOCATIONS*:
477 ;;
478 ;; If NIL, don't store source-notes in function objects, and store only
479 ;; the filename for definitions (the latter only if
480 ;; *record-source-file* is true).
481 ;;
482 ;; If T, store source-notes, including a copy of the original source
483 ;; text, for function objects and definitions (the latter only if
484 ;; *record-source-file* is true).
485 ;;
486 ;; If :NO-TEXT, store source-notes, but without saved text, for
487 ;; function objects and defintions (the latter only if
488 ;; *record-source-file* is true). This is the default.
489 ;;
490 ;; PC to source mapping is controlled by the new variable
491 ;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a
492 ;; compressed table mapping pc offsets to corresponding source locations.
493 ;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc)
494 ;; which returns a source-note for the source at offset pc in the
495 ;; function.
496
497 (defun function-source-location (function)
498 (source-note-to-source-location
499 (or (ccl:function-source-note function)
500 (function-name-source-note function))
501 (lambda ()
502 (format nil "Function has no source note: ~A" function))
503 (ccl:function-name function)))
504
505 (defun pc-source-location (function pc)
506 (source-note-to-source-location
507 (or (ccl:find-source-note-at-pc function pc)
508 (ccl:function-source-note function)
509 (function-name-source-note function))
510 (lambda ()
511 (format nil "No source note at PC: ~a[~d]" function pc))
512 (ccl:function-name function)))
513
514 (defun function-name-source-note (fun)
515 (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function)))
516 (and defs
517 (destructuring-bind ((type . name) srcloc . srclocs) (car defs)
518 (declare (ignore type name srclocs))
519 srcloc))))
520
521 (defun source-note-to-source-location (source if-nil-thunk &optional name)
522 (labels ((filename-to-buffer (filename)
523 (cond ((gethash filename *temp-file-map*)
524 (list :buffer (gethash filename *temp-file-map*)))
525 ((probe-file filename)
526 (list :file (ccl:native-translated-namestring
527 (truename filename))))
528 (t (error "File ~s doesn't exist" filename)))))
529 (handler-case
530 (cond ((ccl:source-note-p source)
531 (let* ((full-text (ccl:source-note-text source))
532 (file-name (ccl:source-note-filename source))
533 (start-pos (ccl:source-note-start-pos source)))
534 (make-location
535 (when file-name (filename-to-buffer (pathname file-name)))
536 (when start-pos (list :position (1+ start-pos)))
537 (when full-text
538 (list :snippet (subseq full-text 0
539 (min 40 (length full-text))))))))
540 ((and source name)
541 ;; This branch is probably never used
542 (make-location
543 (filename-to-buffer source)
544 (list :function-name (princ-to-string
545 (if (functionp name)
546 (ccl:function-name name)
547 name)))))
548 (t `(:error ,(funcall if-nil-thunk))))
549 (error (c) `(:error ,(princ-to-string c))))))
550
551 (defimplementation find-definitions (name)
552 (let ((defs (or (ccl:find-definition-sources name)
553 (and (symbolp name)
554 (fboundp name)
555 (ccl:find-definition-sources (symbol-function name))))))
556 (loop for ((type . name) . sources) in defs
557 collect (list (definition-name type name)
558 (source-note-to-source-location
559 (find-if-not #'null sources)
560 (lambda () "No source-note available")
561 name)))))
562
563 (defimplementation find-source-location (obj)
564 (let* ((defs (ccl:find-definition-sources obj))
565 (best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal)
566 (car defs)))
567 (note (find-if-not #'null (cdr best-def))))
568 (when note
569 (source-note-to-source-location
570 note
571 (lambda () "No source note available")))))
572
573 (defun definition-name (type object)
574 (case (ccl:definition-type-name type)
575 (method (ccl:name-of object))
576 (t (list (ccl:definition-type-name type) (ccl:name-of object)))))
577
578 ;;; Utilities
579
580 (defimplementation describe-symbol-for-emacs (symbol)
581 (let ((result '()))
582 (flet ((doc (kind &optional (sym symbol))
583 (or (documentation sym kind) :not-documented))
584 (maybe-push (property value)
585 (when value
586 (setf result (list* property value result)))))
587 (maybe-push
588 :variable (when (boundp symbol)
589 (doc 'variable)))
590 (maybe-push
591 :function (if (fboundp symbol)
592 (doc 'function)))
593 (maybe-push
594 :setf (let ((setf-function-name (ccl:setf-function-spec-name
595 `(setf ,symbol))))
596 (when (fboundp setf-function-name)
597 (doc 'function setf-function-name))))
598 (maybe-push
599 :type (when (ccl:type-specifier-p symbol)
600 (doc 'type)))
601 result)))
602
603 (defimplementation describe-definition (symbol namespace)
604 (ecase namespace
605 (:variable
606 (describe symbol))
607 ((:function :generic-function)
608 (describe (symbol-function symbol)))
609 (:setf
610 (describe (ccl:setf-function-spec-name `(setf ,symbol))))
611 (:class
612 (describe (find-class symbol)))
613 (:type
614 (describe (or (find-class symbol nil) symbol)))))
615
616 (defimplementation toggle-trace (spec)
617 "We currently ignore just about everything."
618 (ecase (car spec)
619 (setf
620 (ccl:trace-function spec))
621 ((:defgeneric)
622 (ccl:trace-function (second spec)))
623 ((:defmethod)
624 (destructuring-bind (name qualifiers specializers) (cdr spec)
625 (ccl:trace-function
626 (find-method (fdefinition name) qualifiers specializers)))))
627 t)
628
629 ;;; Macroexpansion
630
631 (defimplementation macroexpand-all (form)
632 (ccl:macroexpand-all form))
633
634 ;;;; Inspection
635
636 (defun comment-type-p (type)
637 (or (eq type :comment)
638 (and (consp type) (eq (car type) :comment))))
639
640 (defmethod emacs-inspect ((o t))
641 (let* ((inspector:*inspector-disassembly* t)
642 (i (inspector:make-inspector o))
643 (count (inspector:compute-line-count i)))
644 (loop for l from 0 below count append
645 (multiple-value-bind (value label type) (inspector:line-n i l)
646 (etypecase type
647 ((member nil :normal)
648 `(,(or label "") (:value ,value) (:newline)))
649 ((member :colon)
650 (label-value-line label value))
651 ((member :static)
652 (list (princ-to-string label) " " `(:value ,value) '(:newline)))
653 ((satisfies comment-type-p)
654 (list (princ-to-string label) '(:newline))))))))
655
656 (defmethod emacs-inspect :around ((o t))
657 (if (or (uvector-inspector-p o)
658 (not (ccl:uvectorp o)))
659 (call-next-method)
660 (let ((value (call-next-method)))
661 (cond ((listp value)
662 (append value
663 `((:newline)
664 (:value ,(make-instance 'uvector-inspector :object o)
665 "Underlying UVECTOR"))))
666 (t value)))))
667
668 (defclass uvector-inspector ()
669 ((object :initarg :object)))
670
671 (defgeneric uvector-inspector-p (object)
672 (:method ((object t)) nil)
673 (:method ((object uvector-inspector)) t))
674
675 (defmethod emacs-inspect ((uv uvector-inspector))
676 (with-slots (object) uv
677 (loop for i below (ccl:uvsize object) append
678 (label-value-line (princ-to-string i) (ccl:uvref object i)))))
679
680 ;;; Multiprocessing
681
682 (defvar *known-processes*
683 (make-hash-table :size 20 :weak :key :test #'eq)
684 "A map from threads to mailboxes.")
685
686 (defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*"))
687
688 (defstruct (mailbox (:conc-name mailbox.))
689 (mutex (ccl:make-lock "thread mailbox"))
690 (semaphore (ccl:make-semaphore))
691 (queue '() :type list))
692
693 (defimplementation spawn (fun &key name)
694 (ccl:process-run-function (or name "Anonymous (Swank)")
695 fun))
696
697 (defimplementation thread-id (thread)
698 (ccl:process-serial-number thread))
699
700 (defimplementation find-thread (id)
701 (find id (ccl:all-processes) :key #'ccl:process-serial-number))
702
703 (defimplementation thread-name (thread)
704 (ccl:process-name thread))
705
706 (defimplementation thread-status (thread)
707 (format nil "~A" (ccl:process-whostate thread)))
708
709 (defimplementation thread-attributes (thread)
710 (list :priority (ccl:process-priority thread)))
711
712 (defimplementation make-lock (&key name)
713 (ccl:make-lock name))
714
715 (defimplementation call-with-lock-held (lock function)
716 (ccl:with-lock-grabbed (lock)
717 (funcall function)))
718
719 (defimplementation current-thread ()
720 ccl:*current-process*)
721
722 (defimplementation all-threads ()
723 (ccl:all-processes))
724
725 (defimplementation kill-thread (thread)
726 ;;(ccl:process-kill thread) ; doesn't cut it
727 (ccl::process-initial-form-exited thread :kill))
728
729 (defimplementation thread-alive-p (thread)
730 (not (ccl:process-exhausted-p thread)))
731
732 (defimplementation interrupt-thread (thread function)
733 (ccl:process-interrupt
734 thread
735 (lambda ()
736 (let ((ccl:*top-error-frame* (ccl::%current-exception-frame)))
737 (funcall function)))))
738
739 (defun mailbox (thread)
740 (ccl:with-lock-grabbed (*known-processes-lock*)
741 (or (gethash thread *known-processes*)
742 (setf (gethash thread *known-processes*) (make-mailbox)))))
743
744 (defimplementation send (thread message)
745 (assert message)
746 (let* ((mbox (mailbox thread))
747 (mutex (mailbox.mutex mbox)))
748 (ccl:with-lock-grabbed (mutex)
749 (setf (mailbox.queue mbox)
750 (nconc (mailbox.queue mbox) (list message)))
751 (ccl:signal-semaphore (mailbox.semaphore mbox)))))
752
753 (defimplementation receive-if (test &optional timeout)
754 (let* ((mbox (mailbox ccl:*current-process*))
755 (mutex (mailbox.mutex mbox)))
756 (assert (or (not timeout) (eq timeout t)))
757 (loop
758 (check-slime-interrupts)
759 (ccl:with-lock-grabbed (mutex)
760 (let* ((q (mailbox.queue mbox))
761 (tail (member-if test q)))
762 (when tail
763 (setf (mailbox.queue mbox)
764 (nconc (ldiff q tail) (cdr tail)))
765 (return (car tail)))))
766 (when (eq timeout t) (return (values nil t)))
767 (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))
768
769 (defimplementation set-default-initial-binding (var form)
770 (eval `(ccl::def-standard-initial-binding ,var ,form)))
771
772 (defimplementation quit-lisp ()
773 (ccl:quit))
774
775 ;;; Weak datastructures
776
777 (defimplementation make-weak-key-hash-table (&rest args)
778 (apply #'make-hash-table :weak :key args))
779
780 (defimplementation make-weak-value-hash-table (&rest args)
781 (apply #'make-hash-table :weak :value args))
782
783 (defimplementation hash-table-weakness (hashtable)
784 (ccl:hash-table-weak-p hashtable))

  ViewVC Help
Powered by ViewVC 1.1.5