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

Contents of /slime/swank-ccl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (hide annotations)
Sun Sep 29 07:39:39 2013 UTC (6 months, 2 weeks ago) by heller
Branch: MAIN
Changes since 1.32: +10 -4 lines
For CCL, also search nx1-alphatizer definitions.

* swank-ccl.lisp (alphatizer-definitions): New
(find-definitions): Use it.
1 heller 1.17 ;;;; -*- indent-tabs-mode: nil -*-
2 heller 1.1 ;;;
3 heller 1.17 ;;; swank-ccl.lisp --- SLIME backend for Clozure CL.
4 heller 1.1 ;;;
5     ;;; Copyright (C) 2003, James Bielman <jamesjb@jamesjb.com>
6     ;;;
7     ;;; This program is licensed under the terms of the Lisp Lesser GNU
8 heller 1.17 ;;; Public License, known as the LLGPL, and distributed with Clozure CL
9 heller 1.1 ;;; as the file "LICENSE". The LLGPL consists of a preamble and the
10 heller 1.17 ;;; LGPL, which is distributed with Clozure CL as the file "LGPL". Where
11 heller 1.1 ;;; 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 heller 1.26 (multiple-value-bind (ok err) (ignore-errors (require 'xref))
27     (unless ok
28     (warn "~a~%" err))))
29 heller 1.1
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 heller 1.23 ;;; 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 heller 1.1
95     ;;; TCP Server
96    
97     (defimplementation preferred-communication-style ()
98     :spawn)
99    
100 heller 1.24 (defimplementation create-socket (host port &key backlog)
101 heller 1.1 (ccl:make-socket :connect :passive :local-port port
102 heller 1.24 :local-host host :reuse-address t
103     :backlog (or backlog 5)))
104 heller 1.1
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 heller 1.17 buffering timeout)
113 heller 1.1 (declare (ignore buffering timeout))
114 heller 1.17 (let ((stream-args (and external-format
115     `(:external-format ,external-format))))
116     (ccl:accept-connection socket :wait t :stream-args stream-args)))
117 heller 1.1
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 heller 1.20 (defimplementation socket-fd (stream)
129     (ccl::ioblock-device (ccl::stream-ioblock stream t)))
130    
131 heller 1.1 ;;; 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 sboukarev 1.28 (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 heller 1.1
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 heller 1.31 ;; 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 heller 1.1 (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 sboukarev 1.16 load-p external-format
195     &key policy)
196     (declare (ignore policy))
197 heller 1.1 (with-compilation-hooks ()
198     (compile-file input-file
199     :output-file output-file
200     :load load-p
201     :external-format external-format)))
202    
203 heller 1.17 ;; Use a temp file rather than in-core compilation in order to handle
204     ;; eval-when's as compile-time.
205 heller 1.1 (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 heller 1.27 :if-exists :error :external-format :utf-8)
215 heller 1.1 (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 heller 1.27 :compile-file-original-buffer-offset (1- offset)
234     :external-format :utf-8))
235 heller 1.1
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 heller 1.26 (ccl::get-relation relation name :wild :exhaustive t)
246     (ccl::get-relation relation :wild name :exhaustive t)))
247 heller 1.1 :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 trittweiler 1.8 (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 heller 1.1
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 heller 1.17 ;; 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 heller 1.1 (defun find-repl-thread ()
331 heller 1.18 (let* ((*break-on-signals* nil)
332     (conn (funcall (swank-sym default-connection))))
333 heller 1.1 (and conn
334 heller 1.18 (ignore-errors ;; this errors if no repl-thread
335     (funcall (swank-sym repl-thread) conn)))))
336    
337 heller 1.1 (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 sboukarev 1.7 (start-frame-number 0)
351     end-frame-number)
352 heller 1.1 "Call FUNCTION passing information about each stack frame
353     from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
354 sboukarev 1.7 (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 heller 1.18 :count (- end-frame-number start-frame-number))))
359 heller 1.1
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 heller 1.17 (args (ccl:frame-supplied-arguments p context
374     :unknown-marker unavailable)))
375 heller 1.1 (declare (dynamic-extent unavailable))
376     (if (eq args unavailable)
377 heller 1.17 (format stream " #<Unknown Arguments>")
378     (dolist (arg args)
379     (if (eq arg unavailable)
380     (format stream " #<Unavailable>")
381     (format stream " ~s" arg)))))
382 heller 1.1 (format stream ")"))))
383    
384 sboukarev 1.14 (defmacro with-frame ((p context) frame-number &body body)
385     `(call/frame ,frame-number (lambda (,p ,context) . ,body)))
386    
387 heller 1.1 (defun call/frame (frame-number if-found)
388     (map-backtrace
389     (lambda (p context)
390 sboukarev 1.13 (return-from call/frame
391 heller 1.1 (funcall if-found p context)))
392     frame-number))
393    
394 heller 1.17 (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 heller 1.1
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 heller 1.31 (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 heller 1.30 (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 heller 1.31 (function-name-package name))))
430 heller 1.30
431 heller 1.1 (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 heller 1.11 (or (ccl:function-source-note function)
497     (function-name-source-note function))
498 heller 1.1 (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 heller 1.11 (ccl:function-source-note function)
506     (function-name-source-note function))
507 heller 1.1 (lambda ()
508     (format nil "No source note at PC: ~a[~d]" function pc))
509     (ccl:function-name function)))
510    
511 heller 1.11 (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 heller 1.1 (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 heller 1.17 (list :file (ccl:native-translated-namestring
524     (truename filename))))
525 heller 1.1 (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 sboukarev 1.2 (when file-name (filename-to-buffer (pathname file-name)))
533 heller 1.1 (when start-pos (list :position (1+ start-pos)))
534 heller 1.17 (when full-text
535     (list :snippet (subseq full-text 0
536     (min 40 (length full-text))))))))
537 heller 1.1 ((and source name)
538 heller 1.17 ;; This branch is probably never used
539 heller 1.1 (make-location
540     (filename-to-buffer source)
541 heller 1.17 (list :function-name (princ-to-string
542     (if (functionp name)
543     (ccl:function-name name)
544     name)))))
545 heller 1.1 (t `(:error ,(funcall if-nil-thunk))))
546     (error (c) `(:error ,(princ-to-string c))))))
547    
548 heller 1.33 (defun alphatizer-definitions (name)
549     (let ((alpha (gethash name ccl::*nx1-alphatizers*)))
550     (and alpha (ccl:find-definition-sources alpha))))
551    
552 heller 1.6 (defimplementation find-definitions (name)
553 heller 1.33 (let ((defs (append (or (ccl:find-definition-sources name)
554     (and (symbolp name)
555     (fboundp name)
556     (ccl:find-definition-sources
557     (symbol-function name))))
558     (alphatizer-definitions name))))
559 heller 1.6 (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 heller 1.1
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 heller 1.4 (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 heller 1.1
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 sboukarev 1.19 (defmethod emacs-inspect ((f function))
672     (append
673     (label-value-line "Name" (function-name f))
674     `("Its argument list is: "
675     ,(princ-to-string (arglist f)) (:newline))
676     (label-value-line "Documentation" (documentation f t))
677     (when (function-lambda-expression f)
678     (label-value-line "Lambda Expression"
679     (function-lambda-expression f)))
680     (when (ccl:function-source-note f)
681     (label-value-line "Source note"
682     (ccl:function-source-note f)))
683     (when (typep f 'ccl:compiled-lexical-closure)
684     (append
685     (label-value-line "Inner function" (ccl::closure-function f))
686     '("Closed over values:" (:newline))
687     (loop for (name value) in (ccl::closure-closed-over-values f)
688     append (label-value-line (format nil " ~a" name)
689     value))))))
690    
691 heller 1.1 (defclass uvector-inspector ()
692     ((object :initarg :object)))
693    
694     (defgeneric uvector-inspector-p (object)
695     (:method ((object t)) nil)
696     (:method ((object uvector-inspector)) t))
697    
698     (defmethod emacs-inspect ((uv uvector-inspector))
699     (with-slots (object) uv
700     (loop for i below (ccl:uvsize object) append
701     (label-value-line (princ-to-string i) (ccl:uvref object i)))))
702    
703 sboukarev 1.32 (defimplementation type-specifier-p (symbol)
704     (or (ccl:type-specifier-p symbol)
705     (not (eq (type-specifier-arglist symbol) :not-available))))
706    
707 heller 1.1 ;;; Multiprocessing
708    
709     (defvar *known-processes*
710     (make-hash-table :size 20 :weak :key :test #'eq)
711     "A map from threads to mailboxes.")
712    
713     (defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*"))
714    
715     (defstruct (mailbox (:conc-name mailbox.))
716     (mutex (ccl:make-lock "thread mailbox"))
717     (semaphore (ccl:make-semaphore))
718     (queue '() :type list))
719    
720     (defimplementation spawn (fun &key name)
721 sboukarev 1.22 (ccl:process-run-function (or name "Anonymous (Swank)")
722 heller 1.11 fun))
723    
724 heller 1.1 (defimplementation thread-id (thread)
725     (ccl:process-serial-number thread))
726    
727     (defimplementation find-thread (id)
728     (find id (ccl:all-processes) :key #'ccl:process-serial-number))
729    
730     (defimplementation thread-name (thread)
731     (ccl:process-name thread))
732    
733     (defimplementation thread-status (thread)
734     (format nil "~A" (ccl:process-whostate thread)))
735    
736     (defimplementation thread-attributes (thread)
737     (list :priority (ccl:process-priority thread)))
738    
739     (defimplementation make-lock (&key name)
740     (ccl:make-lock name))
741    
742     (defimplementation call-with-lock-held (lock function)
743     (ccl:with-lock-grabbed (lock)
744     (funcall function)))
745    
746     (defimplementation current-thread ()
747     ccl:*current-process*)
748    
749     (defimplementation all-threads ()
750     (ccl:all-processes))
751    
752     (defimplementation kill-thread (thread)
753 heller 1.10 ;;(ccl:process-kill thread) ; doesn't cut it
754     (ccl::process-initial-form-exited thread :kill))
755 heller 1.1
756     (defimplementation thread-alive-p (thread)
757     (not (ccl:process-exhausted-p thread)))
758    
759     (defimplementation interrupt-thread (thread function)
760     (ccl:process-interrupt
761     thread
762     (lambda ()
763     (let ((ccl:*top-error-frame* (ccl::%current-exception-frame)))
764     (funcall function)))))
765    
766     (defun mailbox (thread)
767     (ccl:with-lock-grabbed (*known-processes-lock*)
768     (or (gethash thread *known-processes*)
769     (setf (gethash thread *known-processes*) (make-mailbox)))))
770    
771     (defimplementation send (thread message)
772     (assert message)
773     (let* ((mbox (mailbox thread))
774     (mutex (mailbox.mutex mbox)))
775     (ccl:with-lock-grabbed (mutex)
776     (setf (mailbox.queue mbox)
777     (nconc (mailbox.queue mbox) (list message)))
778     (ccl:signal-semaphore (mailbox.semaphore mbox)))))
779    
780     (defimplementation receive-if (test &optional timeout)
781     (let* ((mbox (mailbox ccl:*current-process*))
782     (mutex (mailbox.mutex mbox)))
783     (assert (or (not timeout) (eq timeout t)))
784     (loop
785     (check-slime-interrupts)
786     (ccl:with-lock-grabbed (mutex)
787     (let* ((q (mailbox.queue mbox))
788     (tail (member-if test q)))
789     (when tail
790     (setf (mailbox.queue mbox)
791     (nconc (ldiff q tail) (cdr tail)))
792     (return (car tail)))))
793     (when (eq timeout t) (return (values nil t)))
794     (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))
795    
796 heller 1.25 (let ((alist '())
797     (lock (ccl:make-lock "register-thread")))
798    
799     (defimplementation register-thread (name thread)
800     (declare (type symbol name))
801     (ccl:with-lock-grabbed (lock)
802     (etypecase thread
803     (null
804     (setf alist (delete name alist :key #'car)))
805     (ccl:process
806     (let ((probe (assoc name alist)))
807     (cond (probe (setf (cdr probe) thread))
808     (t (setf alist (acons name thread alist))))))))
809     nil)
810    
811     (defimplementation find-registered (name)
812     (ccl:with-lock-grabbed (lock)
813     (cdr (assoc name alist)))))
814    
815 heller 1.1 (defimplementation set-default-initial-binding (var form)
816     (eval `(ccl::def-standard-initial-binding ,var ,form)))
817    
818     (defimplementation quit-lisp ()
819     (ccl:quit))
820    
821     ;;; Weak datastructures
822    
823     (defimplementation make-weak-key-hash-table (&rest args)
824     (apply #'make-hash-table :weak :key args))
825    
826     (defimplementation make-weak-value-hash-table (&rest args)
827     (apply #'make-hash-table :weak :value args))
828    
829     (defimplementation hash-table-weakness (hashtable)
830     (ccl:hash-table-weak-p hashtable))
831 sboukarev 1.29
832     (pushnew 'deinit-log-output ccl:*save-exit-functions*)

  ViewVC Help
Powered by ViewVC 1.1.5