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

Contents of /slime/swank-ccl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.35 - (show annotations)
Fri Nov 1 15:38:50 2013 UTC (5 months, 2 weeks ago) by heller
Branch: MAIN
CVS Tags: HEAD
Changes since 1.34: +5 -4 lines
* swank-ccl.lisp (p2-definitions): Check bounds before accessing
backend-p2-dispatch.
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 (defun alphatizer-definitions (name)
549 (let ((alpha (gethash name ccl::*nx1-alphatizers*)))
550 (and alpha (ccl:find-definition-sources alpha))))
551
552 (defun p2-definitions (name)
553 (let ((nx1-op (gethash name ccl::*nx1-operators*)))
554 (and nx1-op
555 (let ((dispatch (ccl::backend-p2-dispatch ccl::*target-backend*)) )
556 (and (array-in-bounds-p dispatch nx1-op)
557 (let ((p2 (aref dispatch nx1-op)))
558 (and p2
559 (ccl:find-definition-sources p2))))))))
560
561 (defimplementation find-definitions (name)
562 (let ((defs (append (or (ccl:find-definition-sources name)
563 (and (symbolp name)
564 (fboundp name)
565 (ccl:find-definition-sources
566 (symbol-function name))))
567 (alphatizer-definitions name)
568 (p2-definitions name))))
569 (loop for ((type . name) . sources) in defs
570 collect (list (definition-name type name)
571 (source-note-to-source-location
572 (find-if-not #'null sources)
573 (lambda () "No source-note available")
574 name)))))
575
576 (defimplementation find-source-location (obj)
577 (let* ((defs (ccl:find-definition-sources obj))
578 (best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal)
579 (car defs)))
580 (note (find-if-not #'null (cdr best-def))))
581 (when note
582 (source-note-to-source-location
583 note
584 (lambda () "No source note available")))))
585
586 (defun definition-name (type object)
587 (case (ccl:definition-type-name type)
588 (method (ccl:name-of object))
589 (t (list (ccl:definition-type-name type) (ccl:name-of object)))))
590
591 ;;; Utilities
592
593 (defimplementation describe-symbol-for-emacs (symbol)
594 (let ((result '()))
595 (flet ((doc (kind &optional (sym symbol))
596 (or (documentation sym kind) :not-documented))
597 (maybe-push (property value)
598 (when value
599 (setf result (list* property value result)))))
600 (maybe-push
601 :variable (when (boundp symbol)
602 (doc 'variable)))
603 (maybe-push
604 :function (if (fboundp symbol)
605 (doc 'function)))
606 (maybe-push
607 :setf (let ((setf-function-name (ccl:setf-function-spec-name
608 `(setf ,symbol))))
609 (when (fboundp setf-function-name)
610 (doc 'function setf-function-name))))
611 (maybe-push
612 :type (when (ccl:type-specifier-p symbol)
613 (doc 'type)))
614 result)))
615
616 (defimplementation describe-definition (symbol namespace)
617 (ecase namespace
618 (:variable
619 (describe symbol))
620 ((:function :generic-function)
621 (describe (symbol-function symbol)))
622 (:setf
623 (describe (ccl:setf-function-spec-name `(setf ,symbol))))
624 (:class
625 (describe (find-class symbol)))
626 (:type
627 (describe (or (find-class symbol nil) symbol)))))
628
629 (defimplementation toggle-trace (spec)
630 "We currently ignore just about everything."
631 (ecase (car spec)
632 (setf
633 (ccl:trace-function spec))
634 ((:defgeneric)
635 (ccl:trace-function (second spec)))
636 ((:defmethod)
637 (destructuring-bind (name qualifiers specializers) (cdr spec)
638 (ccl:trace-function
639 (find-method (fdefinition name) qualifiers specializers)))))
640 t)
641
642 ;;; Macroexpansion
643
644 (defimplementation macroexpand-all (form)
645 (ccl:macroexpand-all form))
646
647 ;;;; Inspection
648
649 (defun comment-type-p (type)
650 (or (eq type :comment)
651 (and (consp type) (eq (car type) :comment))))
652
653 (defmethod emacs-inspect ((o t))
654 (let* ((inspector:*inspector-disassembly* t)
655 (i (inspector:make-inspector o))
656 (count (inspector:compute-line-count i)))
657 (loop for l from 0 below count append
658 (multiple-value-bind (value label type) (inspector:line-n i l)
659 (etypecase type
660 ((member nil :normal)
661 `(,(or label "") (:value ,value) (:newline)))
662 ((member :colon)
663 (label-value-line label value))
664 ((member :static)
665 (list (princ-to-string label) " " `(:value ,value) '(:newline)))
666 ((satisfies comment-type-p)
667 (list (princ-to-string label) '(:newline))))))))
668
669 (defmethod emacs-inspect :around ((o t))
670 (if (or (uvector-inspector-p o)
671 (not (ccl:uvectorp o)))
672 (call-next-method)
673 (let ((value (call-next-method)))
674 (cond ((listp value)
675 (append value
676 `((:newline)
677 (:value ,(make-instance 'uvector-inspector :object o)
678 "Underlying UVECTOR"))))
679 (t value)))))
680
681 (defmethod emacs-inspect ((f function))
682 (append
683 (label-value-line "Name" (function-name f))
684 `("Its argument list is: "
685 ,(princ-to-string (arglist f)) (:newline))
686 (label-value-line "Documentation" (documentation f t))
687 (when (function-lambda-expression f)
688 (label-value-line "Lambda Expression"
689 (function-lambda-expression f)))
690 (when (ccl:function-source-note f)
691 (label-value-line "Source note"
692 (ccl:function-source-note f)))
693 (when (typep f 'ccl:compiled-lexical-closure)
694 (append
695 (label-value-line "Inner function" (ccl::closure-function f))
696 '("Closed over values:" (:newline))
697 (loop for (name value) in (ccl::closure-closed-over-values f)
698 append (label-value-line (format nil " ~a" name)
699 value))))))
700
701 (defclass uvector-inspector ()
702 ((object :initarg :object)))
703
704 (defgeneric uvector-inspector-p (object)
705 (:method ((object t)) nil)
706 (:method ((object uvector-inspector)) t))
707
708 (defmethod emacs-inspect ((uv uvector-inspector))
709 (with-slots (object) uv
710 (loop for i below (ccl:uvsize object) append
711 (label-value-line (princ-to-string i) (ccl:uvref object i)))))
712
713 (defimplementation type-specifier-p (symbol)
714 (or (ccl:type-specifier-p symbol)
715 (not (eq (type-specifier-arglist symbol) :not-available))))
716
717 ;;; Multiprocessing
718
719 (defvar *known-processes*
720 (make-hash-table :size 20 :weak :key :test #'eq)
721 "A map from threads to mailboxes.")
722
723 (defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*"))
724
725 (defstruct (mailbox (:conc-name mailbox.))
726 (mutex (ccl:make-lock "thread mailbox"))
727 (semaphore (ccl:make-semaphore))
728 (queue '() :type list))
729
730 (defimplementation spawn (fun &key name)
731 (ccl:process-run-function (or name "Anonymous (Swank)")
732 fun))
733
734 (defimplementation thread-id (thread)
735 (ccl:process-serial-number thread))
736
737 (defimplementation find-thread (id)
738 (find id (ccl:all-processes) :key #'ccl:process-serial-number))
739
740 (defimplementation thread-name (thread)
741 (ccl:process-name thread))
742
743 (defimplementation thread-status (thread)
744 (format nil "~A" (ccl:process-whostate thread)))
745
746 (defimplementation thread-attributes (thread)
747 (list :priority (ccl:process-priority thread)))
748
749 (defimplementation make-lock (&key name)
750 (ccl:make-lock name))
751
752 (defimplementation call-with-lock-held (lock function)
753 (ccl:with-lock-grabbed (lock)
754 (funcall function)))
755
756 (defimplementation current-thread ()
757 ccl:*current-process*)
758
759 (defimplementation all-threads ()
760 (ccl:all-processes))
761
762 (defimplementation kill-thread (thread)
763 ;;(ccl:process-kill thread) ; doesn't cut it
764 (ccl::process-initial-form-exited thread :kill))
765
766 (defimplementation thread-alive-p (thread)
767 (not (ccl:process-exhausted-p thread)))
768
769 (defimplementation interrupt-thread (thread function)
770 (ccl:process-interrupt
771 thread
772 (lambda ()
773 (let ((ccl:*top-error-frame* (ccl::%current-exception-frame)))
774 (funcall function)))))
775
776 (defun mailbox (thread)
777 (ccl:with-lock-grabbed (*known-processes-lock*)
778 (or (gethash thread *known-processes*)
779 (setf (gethash thread *known-processes*) (make-mailbox)))))
780
781 (defimplementation send (thread message)
782 (assert message)
783 (let* ((mbox (mailbox thread))
784 (mutex (mailbox.mutex mbox)))
785 (ccl:with-lock-grabbed (mutex)
786 (setf (mailbox.queue mbox)
787 (nconc (mailbox.queue mbox) (list message)))
788 (ccl:signal-semaphore (mailbox.semaphore mbox)))))
789
790 (defimplementation receive-if (test &optional timeout)
791 (let* ((mbox (mailbox ccl:*current-process*))
792 (mutex (mailbox.mutex mbox)))
793 (assert (or (not timeout) (eq timeout t)))
794 (loop
795 (check-slime-interrupts)
796 (ccl:with-lock-grabbed (mutex)
797 (let* ((q (mailbox.queue mbox))
798 (tail (member-if test q)))
799 (when tail
800 (setf (mailbox.queue mbox)
801 (nconc (ldiff q tail) (cdr tail)))
802 (return (car tail)))))
803 (when (eq timeout t) (return (values nil t)))
804 (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))
805
806 (let ((alist '())
807 (lock (ccl:make-lock "register-thread")))
808
809 (defimplementation register-thread (name thread)
810 (declare (type symbol name))
811 (ccl:with-lock-grabbed (lock)
812 (etypecase thread
813 (null
814 (setf alist (delete name alist :key #'car)))
815 (ccl:process
816 (let ((probe (assoc name alist)))
817 (cond (probe (setf (cdr probe) thread))
818 (t (setf alist (acons name thread alist))))))))
819 nil)
820
821 (defimplementation find-registered (name)
822 (ccl:with-lock-grabbed (lock)
823 (cdr (assoc name alist)))))
824
825 (defimplementation set-default-initial-binding (var form)
826 (eval `(ccl::def-standard-initial-binding ,var ,form)))
827
828 (defimplementation quit-lisp ()
829 (ccl:quit))
830
831 ;;; Weak datastructures
832
833 (defimplementation make-weak-key-hash-table (&rest args)
834 (apply #'make-hash-table :weak :key args))
835
836 (defimplementation make-weak-value-hash-table (&rest args)
837 (apply #'make-hash-table :weak :value args))
838
839 (defimplementation hash-table-weakness (hashtable)
840 (ccl:hash-table-weak-p hashtable))
841
842 (pushnew 'deinit-log-output ccl:*save-exit-functions*)

  ViewVC Help
Powered by ViewVC 1.1.5