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

Contents of /slime/swank-openmcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.184 - (show annotations)
Fri Oct 30 10:57:55 2009 UTC (4 years, 5 months ago) by heller
Branch: MAIN
CVS Tags: HEAD
Changes since 1.183: +0 -0 lines
FILE REMOVED
* swank-openmcl.lisp: Removed. 1.4 is out so no longer needed.
* swank-ccl.lisp: Update accordingly.

* test-all.sh: Removed. Not used in ages.
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 ;;;
17 ;;; This is the beginning of a Slime backend for OpenMCL. It has been
18 ;;; tested only with OpenMCL version 0.14-030901 on Darwin --- I would
19 ;;; be interested in hearing the results with other versions.
20 ;;;
21 ;;; Additionally, reporting the positions of warnings accurately requires
22 ;;; a small patch to the OpenMCL file compiler, which may be found at:
23 ;;;
24 ;;; http://www.jamesjb.com/slime/openmcl-warning-position.diff
25 ;;;
26 ;;; Things that work:
27 ;;;
28 ;;; * Evaluation of forms with C-M-x.
29 ;;; * Compilation of defuns with C-c C-c.
30 ;;; * File compilation with C-c C-k.
31 ;;; * Most of the debugger functionality, except EVAL-IN-FRAME,
32 ;;; FRAME-SOURCE-LOCATION, and FRAME-CATCH-TAGS.
33 ;;; * Macroexpanding with C-c RET.
34 ;;; * Disassembling the symbol at point with C-c M-d.
35 ;;; * Describing symbol at point with C-c C-d.
36 ;;; * Compiler warnings are trapped and sent to Emacs using the buffer
37 ;;; position of the offending top level form.
38 ;;; * Symbol completion and apropos.
39 ;;;
40 ;;; Things that sort of work:
41 ;;;
42 ;;; * WHO-CALLS is implemented but is only able to return the file a
43 ;;; caller is defined in---source location information is not
44 ;;; available.
45 ;;;
46 ;;; Things that aren't done yet:
47 ;;;
48 ;;; * Cross-referencing.
49 ;;; * Due to unimplementation functionality the test suite does not
50 ;;; run correctly (it hangs upon entering the debugger).
51 ;;;
52
53 (in-package :swank-backend)
54
55 (eval-when (:compile-toplevel :execute :load-toplevel)
56 (assert (and (= ccl::*openmcl-major-version* 1)
57 (>= ccl::*openmcl-minor-version* 3))
58 () "This file needs CCL version 1.3 or newer"))
59
60 (import-from :ccl *gray-stream-symbols* :swank-backend)
61
62 (eval-when (:compile-toplevel :load-toplevel :execute)
63 (require 'xref))
64
65 ;;; swank-mop
66
67 (import-to-swank-mop
68 '( ;; classes
69 cl:standard-generic-function
70 ccl::standard-slot-definition
71 cl:method
72 cl:standard-class
73 ccl::eql-specializer
74 openmcl-mop:finalize-inheritance
75 ;; standard-class readers
76 openmcl-mop:class-default-initargs
77 openmcl-mop:class-direct-default-initargs
78 openmcl-mop:class-direct-slots
79 openmcl-mop:class-direct-subclasses
80 openmcl-mop:class-direct-superclasses
81 openmcl-mop:class-finalized-p
82 cl:class-name
83 openmcl-mop:class-precedence-list
84 openmcl-mop:class-prototype
85 openmcl-mop:class-slots
86 openmcl-mop:specializer-direct-methods
87 ;; eql-specializer accessors
88 openmcl-mop:eql-specializer-object
89 ;; generic function readers
90 openmcl-mop:generic-function-argument-precedence-order
91 openmcl-mop:generic-function-declarations
92 openmcl-mop:generic-function-lambda-list
93 openmcl-mop:generic-function-methods
94 openmcl-mop:generic-function-method-class
95 openmcl-mop:generic-function-method-combination
96 openmcl-mop:generic-function-name
97 ;; method readers
98 openmcl-mop:method-generic-function
99 openmcl-mop:method-function
100 openmcl-mop:method-lambda-list
101 openmcl-mop:method-specializers
102 openmcl-mop:method-qualifiers
103 ;; slot readers
104 openmcl-mop:slot-definition-allocation
105 ccl::slot-definition-documentation
106 openmcl-mop:slot-value-using-class
107 openmcl-mop:slot-definition-initargs
108 openmcl-mop:slot-definition-initform
109 openmcl-mop:slot-definition-initfunction
110 openmcl-mop:slot-definition-name
111 openmcl-mop:slot-definition-type
112 openmcl-mop:slot-definition-readers
113 openmcl-mop:slot-definition-writers
114 openmcl-mop:slot-boundp-using-class
115 openmcl-mop:slot-makunbound-using-class))
116
117 (defun specializer-name (spec)
118 (etypecase spec
119 (cons spec)
120 (class (class-name spec))
121 (ccl::eql-specializer `(eql ,(ccl::eql-specializer-object spec)))))
122
123 (defun swank-mop:compute-applicable-methods-using-classes (gf args)
124 (let* ((methods (ccl::%gf-methods gf))
125 (args-length (length args))
126 (bits (ccl::inner-lfun-bits gf))
127 arg-count res)
128 (when methods
129 (setq arg-count (length (ccl::%method-specializers (car methods))))
130 (unless (<= arg-count args-length)
131 (error "Too few args to ~s" gf))
132 (unless (or (logbitp ccl::$lfbits-rest-bit bits)
133 (logbitp ccl::$lfbits-restv-bit bits)
134 (logbitp ccl::$lfbits-keys-bit bits)
135 (<= args-length
136 (+ (ldb ccl::$lfbits-numreq bits) (ldb ccl::$lfbits-numopt bits))))
137 (error "Too many args to ~s" gf))
138 (let ((cpls (make-list arg-count)))
139 (declare (dynamic-extent cpls))
140 (do* ((args-tail args (cdr args-tail))
141 (cpls-tail cpls (cdr cpls-tail)))
142 ((null cpls-tail))
143 (setf (car cpls-tail)
144 (ccl::%class-precedence-list (car args-tail))))
145 (flet ((%method-applicable-p (method args cpls)
146 (do* ((specs (ccl::%method-specializers method) (ccl::%cdr specs))
147 (args args (ccl::%cdr args))
148 (cpls cpls (ccl::%cdr cpls)))
149 ((null specs) t)
150 (let ((spec (ccl::%car specs)))
151 (if (typep spec 'ccl::eql-specializer)
152 (unless (subtypep (ccl::%car args) (class-of (ccl::eql-specializer-object spec)))
153 (return nil))
154 (unless (ccl:memq spec (ccl::%car cpls))
155 (return nil)))))))
156 (dolist (m methods)
157 (if (%method-applicable-p m args cpls)
158 (push m res))))
159 (ccl::sort-methods res cpls (ccl::%gf-precedence-list gf))))))
160
161 ;;; TCP Server
162
163 (defimplementation preferred-communication-style ()
164 :spawn)
165
166 (defimplementation create-socket (host port)
167 (ccl:make-socket :connect :passive :local-port port
168 :local-host host :reuse-address t))
169
170 (defimplementation local-port (socket)
171 (ccl:local-port socket))
172
173 (defimplementation close-socket (socket)
174 (close socket))
175
176 (defimplementation accept-connection (socket &key external-format
177 buffering timeout)
178 (declare (ignore buffering timeout))
179 (when external-format
180 (let ((keys (ccl::socket-keys socket)))
181 (setf (getf keys :external-format) external-format
182 (slot-value socket 'ccl::keys) keys)))
183 (ccl:accept-connection socket :wait t))
184
185 (defvar *external-format-to-coding-system*
186 '((:iso-8859-1
187 "latin-1" "latin-1-unix" "iso-latin-1-unix"
188 "iso-8859-1" "iso-8859-1-unix")
189 (:utf-8 "utf-8" "utf-8-unix")))
190
191 (defimplementation find-external-format (coding-system)
192 (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
193 *external-format-to-coding-system*)))
194
195 ;;; Unix signals
196
197 (defimplementation call-without-interrupts (fn)
198 (ccl:without-interrupts (funcall fn)))
199
200 (defimplementation getpid ()
201 (ccl::getpid))
202
203 (defimplementation lisp-implementation-type-name ()
204 "ccl")
205
206 ;;; Arglist
207
208 (defimplementation arglist (fname)
209 (multiple-value-bind (arglist binding) (arglist% fname)
210 (if binding
211 arglist
212 :not-available)))
213
214 (defmethod arglist% ((f symbol))
215 (ccl:arglist f))
216
217 (defmethod arglist% ((f function))
218 (ccl:arglist (ccl:function-name f)))
219
220 (defimplementation function-name (function)
221 (ccl:function-name function))
222
223 (defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
224 (let ((flags (ccl:declaration-information decl-identifier)))
225 (if flags
226 `(&any ,flags)
227 (call-next-method))))
228
229 ;;; Compilation
230
231 (defun handle-compiler-warning (condition)
232 "Resignal a ccl:compiler-warning as swank-backend:compiler-warning."
233 (signal (make-condition
234 'compiler-condition
235 :original-condition condition
236 :message (compiler-warning-short-message condition)
237 :source-context nil
238 :severity (compiler-warning-severity condition)
239 :location (source-note-to-source-location
240 (ccl::compiler-warning-source-note condition)
241 (lambda () "Unknown source")))))
242
243 (defgeneric compiler-warning-severity (condition))
244 (defmethod compiler-warning-severity ((c ccl::compiler-warning)) :warning)
245 (defmethod compiler-warning-severity ((c ccl::style-warning)) :style-warning)
246
247 (defgeneric compiler-warning-short-message (condition))
248
249 ;; Pretty much the same as ccl::report-compiler-warning but
250 ;; without the source position and function name stuff.
251 (defmethod compiler-warning-short-message ((c ccl::compiler-warning))
252 (with-accessors ((type ccl::compiler-warning-warning-type)
253 (args ccl::compiler-warning-args)
254 (nrefs ccl::compiler-warning-nrefs)) c
255 (with-output-to-string (stream)
256 (let ((format-string (cdr (assoc type ccl::*compiler-warning-formats*))))
257 (typecase format-string
258 (string (apply #'format stream format-string
259 (ccl::adjust-compiler-warning-args type args)))
260 (null (format stream "~A: ~S" type args))
261 (t (funcall format-string c stream)))
262 (let ((nrefs (cond ((numberp nrefs) nrefs)
263 ((consp nrefs) (length nrefs)))))
264 (when (and nrefs (/= nrefs 1))
265 (format stream " (~D references)" nrefs)))))))
266
267 (defimplementation call-with-compilation-hooks (function)
268 (handler-bind ((ccl::compiler-warning 'handle-compiler-warning))
269 (funcall function)))
270
271 (defimplementation swank-compile-file (input-file output-file
272 load-p external-format)
273 (with-compilation-hooks ()
274 (compile-file input-file
275 :output-file output-file
276 :load load-p
277 :external-format external-format)))
278
279 (defun temp-file-name ()
280 "Return a temporary file name to compile strings into."
281 (ccl:%get-cstring (#_tmpnam (ccl:%null-ptr))))
282
283 (defimplementation swank-compile-string (string &key buffer position filename
284 policy)
285 (declare (ignore policy))
286 (with-compilation-hooks ()
287 (let ((temp-file-name (temp-file-name))
288 (ccl:*save-source-locations* t))
289 (unwind-protect
290 (progn
291 (with-open-file (s temp-file-name :direction :output
292 :if-exists :error)
293 (write-string string s))
294 (let ((binary-filename (compile-temp-file
295 temp-file-name filename buffer position)))
296 (delete-file binary-filename)))
297 (delete-file temp-file-name)))))
298
299 (defvar *temp-file-map* (make-hash-table :test #'equal)
300 "A mapping from tempfile names to Emacs buffer names.")
301
302 (defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset)
303 (compile-file temp-file-name
304 :load t
305 :compile-file-original-truename
306 (or buffer-file-name
307 (progn
308 (setf (gethash temp-file-name *temp-file-map*)
309 buffer-name)
310 temp-file-name))
311 :compile-file-original-buffer-offset (1- offset)))
312
313 ;;; Cross-referencing
314
315 (defun xref-locations (relation name &optional inverse)
316 (mapcan #'find-definitions
317 (if inverse
318 (ccl::get-relation relation name :wild :exhaustive t)
319 (ccl::get-relation relation :wild name :exhaustive t))))
320
321 (defimplementation who-binds (name)
322 (xref-locations :binds name))
323
324 (defimplementation who-macroexpands (name)
325 (xref-locations :macro-calls name t))
326
327 (defimplementation who-references (name)
328 (remove-duplicates
329 (append (xref-locations :references name)
330 (xref-locations :sets name)
331 (xref-locations :binds name))
332 :test 'equal))
333
334 (defimplementation who-sets (name)
335 (xref-locations :sets name))
336
337 (defimplementation who-calls (name)
338 (remove-duplicates
339 (append
340 (xref-locations :direct-calls name)
341 (xref-locations :indirect-calls name)
342 (xref-locations :macro-calls name t))
343 :test 'equal))
344
345 (defimplementation who-specializes (class)
346 (mapcar (lambda (m)
347 (car (find-definitions m)))
348 (ccl::%class.direct-methods (find-class class))))
349
350 (defimplementation list-callees (name)
351 (remove-duplicates
352 (append
353 (xref-locations :direct-calls name t)
354 (xref-locations :macro-calls name nil))
355 :test 'equal))
356
357 (defimplementation list-callers (symbol)
358 (mapcan #'find-definitions (ccl::caller-functions symbol)))
359
360 ;;; Profiling (alanr: lifted from swank-clisp)
361
362 (defimplementation profile (fname)
363 (eval `(mon:monitor ,fname))) ;monitor is a macro
364
365 (defimplementation profiled-functions ()
366 mon:*monitored-functions*)
367
368 (defimplementation unprofile (fname)
369 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
370
371 (defimplementation unprofile-all ()
372 (mon:unmonitor))
373
374 (defimplementation profile-report ()
375 (mon:report-monitoring))
376
377 (defimplementation profile-reset ()
378 (mon:reset-all-monitoring))
379
380 (defimplementation profile-package (package callers-p methods)
381 (declare (ignore callers-p methods))
382 (mon:monitor-all package))
383
384 ;;; Debugging
385
386 (defun openmcl-set-debug-switches ()
387 (setq ccl::*fasl-save-definitions* nil)
388 (setq ccl::*fasl-save-doc-strings* t)
389 (setq ccl::*fasl-save-local-symbols* t)
390 #+ppc (setq ccl::*ppc2-compiler-register-save-label* t)
391 #+x86-64 (setq ccl::*x862-compiler-register-save-label* t)
392 (setq ccl::*save-arglist-info* t)
393 (setq ccl::*save-definitions* nil)
394 (setq ccl::*save-doc-strings* t)
395 (setq ccl::*save-local-symbols* t)
396 (ccl::start-xref))
397
398 (defvar *sldb-stack-top* nil)
399 (defvar *sldb-stack-top-hint* nil)
400 (defvar *break-in-sldb* nil)
401
402 (defimplementation call-with-debugging-environment (debugger-loop-fn)
403 (let* (;;(*debugger-hook* nil)
404 (*sldb-stack-top* (or *sldb-stack-top-hint*
405 (guess-stack-top 2)))
406 (*sldb-stack-top-hint* nil)
407 ;; don't let error while printing error take us down
408 (ccl::*signal-printing-errors* nil))
409 (funcall debugger-loop-fn)))
410
411 (defimplementation call-with-debugger-hook (hook fun)
412 (let ((*debugger-hook* hook)
413 (*break-in-sldb* t))
414 (funcall fun)))
415
416 (defimplementation install-debugger-globally (function)
417 (setq *debugger-hook* function)
418 (setq *break-in-sldb* t)
419 ;;(setq ccl::*interactive-abort-process* ccl::*current-process*)
420 )
421
422 (defun backtrace-context ()
423 nil)
424
425 (labels ((error-entry? (frame)
426 (let ((fun (ccl::cfp-lfun frame)))
427 (or (eq fun #'ccl::%error)
428 (eq fun #'ccl::%pascal-functions%)))))
429
430 (defun guess-stack-top (offset)
431 ;; search the beginning of the stack for some well known functions
432 (do ((ctx (backtrace-context))
433 (result (ccl::%get-frame-ptr))
434 (i 0 (1+ i))
435 (frame (ccl::%get-frame-ptr) (ccl::parent-frame frame ctx))
436 (last nil frame))
437 (nil)
438 (cond ((or (not frame) (or (> i (+ offset 7))))
439 (return result))
440 ((or (= i offset) (and last (error-entry? last)))
441 (setq result frame))))))
442
443 (defun map-backtrace (function &optional
444 (start-frame-number 0)
445 (end-frame-number most-positive-fixnum))
446 "Call FUNCTION passing information about each stack frame
447 from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
448 (let ((context (backtrace-context))
449 (frame-number 0)
450 (top-stack-frame (or *sldb-stack-top*
451 (ccl::%get-frame-ptr))))
452 (do ((p top-stack-frame (ccl::parent-frame p context)))
453 ((null p))
454 (multiple-value-bind (lfun pc) (ccl::cfp-lfun p)
455 (when lfun
456 (if (and (>= frame-number start-frame-number)
457 (< frame-number end-frame-number))
458 (funcall function frame-number p context lfun pc))
459 (incf frame-number))))))
460
461 (defun frame-arguments (p context lfun pc)
462 "Returns a list representing the arguments of a frame."
463 (multiple-value-bind (args types names)
464 (ccl::frame-supplied-args p lfun pc nil context)
465 (loop for value in args
466 for type in types
467 for name in names
468 append (cond ((equal type "keyword")
469 (list (intern (symbol-name name) "KEYWORD") value))
470 (t (list value))))))
471
472 (defimplementation compute-backtrace (start-frame-number end-frame-number)
473 (let (result)
474 (map-backtrace (lambda (frame-number p context lfun pc)
475 (declare (ignore frame-number))
476 (push (list :frame p context lfun pc)
477 result))
478 start-frame-number end-frame-number)
479 (nreverse result)))
480
481 (defimplementation print-frame (frame stream)
482 (assert (eq (first frame) :frame))
483 (destructuring-bind (p context lfun pc) (rest frame)
484 (format stream "(~S~{ ~S~})"
485 (or (ccl::function-name lfun) lfun)
486 (frame-arguments p context lfun pc))))
487
488 (defun call/frame (frame-number if-found)
489 (map-backtrace
490 (lambda (fnumber p context lfun pc)
491 (when (= fnumber frame-number)
492 (return-from call/frame
493 (funcall if-found p context lfun pc))))))
494
495 (defmacro with-frame ((p context lfun pc) frame-number &body body)
496 `(call/frame ,frame-number (lambda (,p ,context ,lfun ,pc) . ,body)))
497
498 (defimplementation frame-var-value (frame var)
499 (with-frame (p context lfun pc) frame
500 (cadr (nth var (frame-visible-variables p context lfun pc)))))
501
502 (defimplementation frame-locals (index)
503 (with-frame (p context lfun pc) index
504 (loop for (name value) in (frame-visible-variables p context lfun pc)
505 collect (list :name name :value value :id 0))))
506
507 (defun frame-visible-variables (p context lfun pc)
508 "Return a list ((NAME VALUE) ...) of the named variables for this frame."
509 (multiple-value-bind (count vsp parent-vsp)
510 (ccl::count-values-in-frame p context)
511 (let (result)
512 (dotimes (i count)
513 (multiple-value-bind (var type name)
514 (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp)
515 (declare (ignore type))
516 (when name
517 (let ((value (typecase var
518 (ccl::value-cell (ccl::uvref var 0))
519 (t var))))
520 (push (list name value) result)))))
521 (reverse result))))
522
523 (defimplementation frame-source-location (index)
524 (with-frame (p context lfun pc) index
525 (declare (ignore p context))
526 (if pc
527 (pc-source-location lfun pc)
528 (function-source-location lfun))))
529
530 (defimplementation eval-in-frame (form index)
531 (with-frame (p context lfun pc) index
532 (let ((vars (frame-visible-variables p context lfun pc)))
533 (eval `(let ,(loop for (var val) in vars collect `(,var ',val))
534 (declare (ignorable ,@(mapcar #'car vars)))
535 ,form)))))
536
537 (defimplementation return-from-frame (index form)
538 (let ((values (multiple-value-list (eval-in-frame form index))))
539 (with-frame (p context lfun pc) index
540 (declare (ignore context lfun pc))
541 (ccl::apply-in-frame p #'values values))))
542
543 (defimplementation restart-frame (index)
544 (with-frame (p context lfun pc) index
545 (ccl::apply-in-frame p lfun
546 (ccl::frame-supplied-args p lfun pc nil context))))
547
548 (defimplementation disassemble-frame (the-frame-number)
549 (with-frame (p context lfun pc) the-frame-number
550 (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context)
551 (disassemble lfun)))
552
553 ;; BREAK
554
555 (ccl::advise ccl::cbreak-loop
556 (if *break-in-sldb*
557 (apply #'break-in-sldb ccl::arglist)
558 (:do-it))
559 :when :around
560 :name sldb-break)
561
562 (defun break-in-sldb (msg cont-string condition error-pointer)
563 (let ((*sldb-stack-top-hint* error-pointer))
564 (with-simple-restart (continue "~a" cont-string)
565 (funcall (read-from-string "SWANK:INVOKE-SLIME-DEBUGGER")
566 (condition-for-break condition msg)))))
567
568 (defun condition-for-break (condition msg)
569 (cond ((and (eq (type-of condition) 'simple-condition)
570 (equal (simple-condition-format-control condition) ""))
571 (make-condition 'simple-condition :format-control "~a"
572 :format-arguments (list msg)))
573 (t condition)))
574
575
576 ;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008)
577 ;; contains some interesting details:
578 ;;
579 ;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects
580 ;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS,
581 ;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end
582 ;; positions are file positions (not character positions). The text will
583 ;; be NIL unless text recording was on at read-time. If the original
584 ;; file is still available, you can force missing source text to be read
585 ;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.
586 ;;
587 ;; Source-note's are associated with definitions (via record-source-file)
588 ;; and also stored in function objects (including anonymous and nested
589 ;; functions). The former can be retrieved via
590 ;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.
591 ;;
592 ;; The recording behavior is controlled by the new variable
593 ;; CCL:*SAVE-SOURCE-LOCATIONS*:
594 ;;
595 ;; If NIL, don't store source-notes in function objects, and store only
596 ;; the filename for definitions (the latter only if
597 ;; *record-source-file* is true).
598 ;;
599 ;; If T, store source-notes, including a copy of the original source
600 ;; text, for function objects and definitions (the latter only if
601 ;; *record-source-file* is true).
602 ;;
603 ;; If :NO-TEXT, store source-notes, but without saved text, for
604 ;; function objects and defintions (the latter only if
605 ;; *record-source-file* is true). This is the default.
606 ;;
607 ;; PC to source mapping is controlled by the new variable
608 ;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a
609 ;; compressed table mapping pc offsets to corresponding source locations.
610 ;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc)
611 ;; which returns a source-note for the source at offset pc in the
612 ;; function.
613 ;;
614 ;; Currently the only thing that makes use of any of this is the
615 ;; disassembler. ILISP and current version of Slime still use
616 ;; backward-compatible functions that deal with filenames only. The plan
617 ;; is to make Slime, and our IDE, use this eventually.
618
619 (defun function-source-location (function)
620 (source-note-to-source-location
621 (ccl:function-source-note function)
622 (lambda ()
623 (format nil "Function has no source note: ~A" function))))
624
625 (defun pc-source-location (function pc)
626 (source-note-to-source-location
627 (or (ccl:find-source-note-at-pc function pc)
628 (ccl:function-source-note function))
629 (lambda ()
630 (format nil "No source note at PC: ~a[~d]" function pc))))
631
632 (defun source-note-to-source-location (note if-nil-thunk)
633 (labels ((filename-to-buffer (filename)
634 (cond ((gethash filename *temp-file-map*)
635 (list :buffer (gethash filename *temp-file-map*)))
636 ((probe-file filename)
637 (list :file (namestring (truename filename))))
638 (t (error "File ~s doesn't exist" filename)))))
639 (cond (note
640 (handler-case
641 (make-location
642 (filename-to-buffer (ccl:source-note-filename note))
643 (list :position (1+ (ccl:source-note-start-pos note))))
644 (error (c)
645 ;;(break "~a" c)
646 `(:error ,(princ-to-string c)))))
647 (t `(:error ,(funcall if-nil-thunk))))))
648
649 (defimplementation find-definitions (obj)
650 (loop for (loc . name) in (source-locations obj)
651 collect (list name loc)))
652
653 ;; Return a list ((LOC . NAME) ...) of possible src-locs.
654 (defgeneric source-locations (thing))
655
656 (defmethod source-locations ((f function))
657 (list (cons (function-source-location f)
658 (list 'function (ccl:function-name f)))))
659
660 (defmethod source-locations ((s symbol))
661 (append
662 #+(or)
663 (if (and (fboundp s)
664 (not (macro-function s))
665 (not (special-operator-p s))
666 (functionp (symbol-function s)))
667 (source-locations (symbol-function s)))
668 (loop for ((type . name) source) in (ccl:find-definition-sources s)
669 collect (cons (source-note-to-source-location
670 source (lambda () "No source info available"))
671 (definition-name type name)))))
672
673 (defmethod source-locations ((m method))
674 (list (cons (function-source-location (ccl::method-function m))
675 (definition-name ccl::*method-definition-type* m))))
676
677 (defmethod source-locations ((xe ccl::xref-entry))
678 (with-slots (ccl::name type method-qualifiers ccl::method-specializers) xe
679 (let ((name (case type
680 (method
681 `(,ccl::name ,@method-qualifiers ,ccl::method-specializers))
682 (t ccl::name))))
683 (loop for ((type . name) src) in (ccl:find-definition-sources name type)
684 collect (cons (source-note-to-source-location
685 src (lambda () "No source-note available"))
686 (definition-name type name))))))
687
688 (defgeneric definition-name (type object)
689 (:method ((type ccl::definition-type) object)
690 (list (ccl::definition-type-name type) object)))
691
692 (defmethod definition-name ((type ccl::method-definition-type)
693 (met method))
694 `(,(ccl::definition-type-name type)
695 ,(ccl::method-name met)
696 ,@(ccl::method-qualifiers met)
697 ,(mapcar #'specializer-name (ccl::method-specializers met))))
698
699 ;;; Utilities
700
701 (defimplementation describe-symbol-for-emacs (symbol)
702 (let ((result '()))
703 (flet ((doc (kind &optional (sym symbol))
704 (or (documentation sym kind) :not-documented))
705 (maybe-push (property value)
706 (when value
707 (setf result (list* property value result)))))
708 (maybe-push
709 :variable (when (boundp symbol)
710 (doc 'variable)))
711 (maybe-push
712 :function (if (fboundp symbol)
713 (doc 'function)))
714 (maybe-push
715 :setf (let ((setf-function-name (ccl::setf-function-spec-name
716 `(setf ,symbol))))
717 (when (fboundp setf-function-name)
718 (doc 'function setf-function-name))))
719 (maybe-push
720 :type (when (ccl:type-specifier-p symbol)
721 (doc 'type)))
722 result)))
723
724 (defimplementation describe-definition (symbol namespace)
725 (ecase namespace
726 (:variable
727 (describe symbol))
728 ((:function :generic-function)
729 (describe (symbol-function symbol)))
730 (:setf
731 (describe (ccl::setf-function-spec-name `(setf ,symbol))))
732 (:class
733 (describe (find-class symbol)))
734 (:type
735 (describe (or (find-class symbol nil) symbol)))))
736
737 (defimplementation toggle-trace (spec)
738 "We currently ignore just about everything."
739 (ecase (car spec)
740 (setf
741 (ccl:trace-function spec))
742 ((:defgeneric)
743 (ccl:trace-function (second spec)))
744 ((:defmethod)
745 (destructuring-bind (name qualifiers specializers) (cdr spec)
746 (ccl:trace-function
747 (find-method (fdefinition name) qualifiers specializers)))))
748 t)
749
750 ;;; Macroexpansion
751
752 (defvar *value2tag* (make-hash-table))
753
754 (do-symbols (s (find-package 'arch))
755 (if (and (> (length (symbol-name s)) 7)
756 (string= (symbol-name s) "SUBTAG-" :end1 7)
757 (boundp s)
758 (numberp (symbol-value s))
759 (< (symbol-value s) 255))
760 (setf (gethash (symbol-value s) *value2tag*) s)))
761
762 (defimplementation macroexpand-all (form)
763 (ccl:macroexpand-all form))
764
765 ;;;; Inspection
766
767 (defimplementation describe-primitive-type (thing)
768 (let ((typecode (ccl::typecode thing)))
769 (if (gethash typecode *value2tag*)
770 (string (gethash typecode *value2tag*))
771 (string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm))))))
772
773 (defun comment-type-p (type)
774 (or (eq type :comment)
775 (and (consp type) (eq (car type) :comment))))
776
777 (defmethod emacs-inspect ((o t))
778 (let* ((inspector::*inspector-disassembly* t)
779 (i (inspector::make-inspector o))
780 (count (inspector::compute-line-count i)))
781 (loop for l from 0 below count append
782 (multiple-value-bind (value label type) (inspector::line-n i l)
783 (etypecase type
784 ((member nil :normal)
785 `(,(or label "") (:value ,value) (:newline)))
786 ((member :colon)
787 (label-value-line label value))
788 ((member :static)
789 (list (princ-to-string label) " " `(:value ,value) '(:newline)))
790 ((satisfies comment-type-p)
791 (list (princ-to-string label) '(:newline))))))))
792
793 (defmethod emacs-inspect :around ((o t))
794 (if (or (uvector-inspector-p o)
795 (not (ccl:uvectorp o)))
796 (call-next-method)
797 (let ((value (call-next-method)))
798 (cond ((listp value)
799 (append value
800 `((:newline)
801 (:value ,(make-instance 'uvector-inspector :object o)
802 "Underlying UVECTOR"))))
803 (t value)))))
804
805 (defclass uvector-inspector ()
806 ((object :initarg :object)))
807
808 (defgeneric uvector-inspector-p (object)
809 (:method ((object t)) nil)
810 (:method ((object uvector-inspector)) t))
811
812 (defmethod emacs-inspect ((uv uvector-inspector))
813 (with-slots (object) uv
814 (loop for i below (ccl::uvsize object) append
815 (label-value-line (princ-to-string i) (ccl::uvref object i)))))
816
817 ;;; Multiprocessing
818
819 (defvar *known-processes*
820 (make-hash-table :size 20 :weak :key :test #'eq)
821 "A map from threads to mailboxes.")
822
823 (defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*"))
824
825 (defstruct (mailbox (:conc-name mailbox.))
826 (mutex (ccl:make-lock "thread mailbox"))
827 (semaphore (ccl:make-semaphore))
828 (queue '() :type list))
829
830 (defimplementation spawn (fun &key name)
831 (ccl:process-run-function
832 (or name "Anonymous (Swank)")
833 (lambda ()
834 (handler-bind ((ccl:process-reset (lambda (c) c nil)))
835 (funcall fun)))))
836
837 (defimplementation thread-id (thread)
838 (ccl::process-serial-number thread))
839
840 (defimplementation find-thread (id)
841 (find id (ccl:all-processes) :key #'ccl::process-serial-number))
842
843 (defimplementation thread-name (thread)
844 (ccl::process-name thread))
845
846 (defimplementation thread-status (thread)
847 (format nil "~A" (ccl:process-whostate thread)))
848
849 (defimplementation thread-attributes (thread)
850 (list :priority (ccl::process-priority thread)))
851
852 (defimplementation make-lock (&key name)
853 (ccl:make-lock name))
854
855 (defimplementation call-with-lock-held (lock function)
856 (ccl:with-lock-grabbed (lock)
857 (funcall function)))
858
859 (defimplementation current-thread ()
860 ccl:*current-process*)
861
862 (defimplementation all-threads ()
863 (ccl:all-processes))
864
865 (defimplementation kill-thread (thread)
866 (and (ccl:process-interrupt thread
867 (lambda ()
868 (ccl::maybe-finish-process-kill
869 ccl:*current-process* :kill)))
870 (setf (ccl::process-kill-issued thread) t)))
871
872 (defimplementation thread-alive-p (thread)
873 (not (ccl::process-exhausted-p thread)))
874
875 (defimplementation interrupt-thread (thread function)
876 (ccl:process-interrupt
877 thread
878 (lambda ()
879 (let ((*sldb-stack-top-hint* (or *sldb-stack-top-hint*
880 (ccl::%get-frame-ptr))))
881 (funcall function)))))
882
883 (defun mailbox (thread)
884 (ccl:with-lock-grabbed (*known-processes-lock*)
885 (or (gethash thread *known-processes*)
886 (setf (gethash thread *known-processes*) (make-mailbox)))))
887
888 (defimplementation send (thread message)
889 (assert message)
890 (let* ((mbox (mailbox thread))
891 (mutex (mailbox.mutex mbox)))
892 (ccl:with-lock-grabbed (mutex)
893 (setf (mailbox.queue mbox)
894 (nconc (mailbox.queue mbox) (list message)))
895 (ccl:signal-semaphore (mailbox.semaphore mbox)))))
896
897 (defimplementation receive-if (test &optional timeout)
898 (let* ((mbox (mailbox ccl:*current-process*))
899 (mutex (mailbox.mutex mbox)))
900 (assert (or (not timeout) (eq timeout t)))
901 (loop
902 (check-slime-interrupts)
903 (ccl:with-lock-grabbed (mutex)
904 (let* ((q (mailbox.queue mbox))
905 (tail (member-if test q)))
906 (when tail
907 (setf (mailbox.queue mbox)
908 (nconc (ldiff q tail) (cdr tail)))
909 (return (car tail)))))
910 (when (eq timeout t) (return (values nil t)))
911 (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))
912
913 (defimplementation set-default-initial-binding (var form)
914 (eval `(ccl::def-standard-initial-binding ,var ,form)))
915
916 (defimplementation quit-lisp ()
917 (ccl::quit))
918
919 ;;; Weak datastructures
920
921 (defimplementation make-weak-key-hash-table (&rest args)
922 (apply #'make-hash-table :weak :key args))
923
924 (defimplementation make-weak-value-hash-table (&rest args)
925 (apply #'make-hash-table :weak :value args))
926
927 (defimplementation hash-table-weakness (hashtable)
928 (ccl::hash-table-weak-p hashtable))

  ViewVC Help
Powered by ViewVC 1.1.5