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

Contents of /slime/swank-ccl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (show annotations)
Sun Nov 27 21:47:15 2011 UTC (2 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.23: +3 -2 lines
* swank.lisp (create-server): Add a :backlog argument.
(setup-server): Pass it along.

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

  ViewVC Help
Powered by ViewVC 1.1.5