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

Contents of /slime/swank-ccl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (show annotations)
Tue Mar 2 12:38:06 2010 UTC (4 years, 1 month ago) by sboukarev
Branch: MAIN
Changes since 1.15: +3 -1 lines
* slime.el (slime-compile-and-load-file): Accept C-u arguments for
compilation policy the same way as slime-compile-defun.

* swank.lisp (compile-file-for-emacs): Take an additional policy argument.
* swank-backend.lisp (swank-compile-file): Ditto.

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

  ViewVC Help
Powered by ViewVC 1.1.5