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

Contents of /slime/swank-ccl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.32 - (show annotations)
Sat Feb 2 10:11:16 2013 UTC (14 months, 2 weeks ago) by sboukarev
Branch: MAIN
Changes since 1.31: +4 -0 lines
* swank-backend.lisp (type-specifier-p): New.
Implement it for ACL, ECL, CCL, Clisp, SBCL, LW.

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

  ViewVC Help
Powered by ViewVC 1.1.5