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

Contents of /slime/swank-ccl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5