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

Contents of /slime/swank-ccl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29 - (hide annotations)
Mon Dec 3 03:43:16 2012 UTC (16 months, 2 weeks ago) by sboukarev
Branch: MAIN
Changes since 1.28: +2 -0 lines
* swank-backend.lisp (deinit-log-output): Move from swank-sbcl,
use it on CCL in ccl:*save-exit-functions* as well.
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     (defimplementation call-with-compilation-hooks (function)
184     (handler-bind ((ccl:compiler-warning 'handle-compiler-warning))
185     (let ((ccl:*merge-compiler-warnings* nil))
186     (funcall function))))
187    
188     (defimplementation swank-compile-file (input-file output-file
189 sboukarev 1.16 load-p external-format
190     &key policy)
191     (declare (ignore policy))
192 heller 1.1 (with-compilation-hooks ()
193     (compile-file input-file
194     :output-file output-file
195     :load load-p
196     :external-format external-format)))
197    
198 heller 1.17 ;; Use a temp file rather than in-core compilation in order to handle
199     ;; eval-when's as compile-time.
200 heller 1.1 (defimplementation swank-compile-string (string &key buffer position filename
201     policy)
202     (declare (ignore policy))
203     (with-compilation-hooks ()
204     (let ((temp-file-name (ccl:temp-pathname))
205     (ccl:*save-source-locations* t))
206     (unwind-protect
207     (progn
208     (with-open-file (s temp-file-name :direction :output
209 heller 1.27 :if-exists :error :external-format :utf-8)
210 heller 1.1 (write-string string s))
211     (let ((binary-filename (compile-temp-file
212     temp-file-name filename buffer position)))
213     (delete-file binary-filename)))
214     (delete-file temp-file-name)))))
215    
216     (defvar *temp-file-map* (make-hash-table :test #'equal)
217     "A mapping from tempfile names to Emacs buffer names.")
218    
219     (defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset)
220     (compile-file temp-file-name
221     :load t
222     :compile-file-original-truename
223     (or buffer-file-name
224     (progn
225     (setf (gethash temp-file-name *temp-file-map*)
226     buffer-name)
227     temp-file-name))
228 heller 1.27 :compile-file-original-buffer-offset (1- offset)
229     :external-format :utf-8))
230 heller 1.1
231     (defimplementation save-image (filename &optional restart-function)
232     (ccl:save-application filename :toplevel-function restart-function))
233    
234     ;;; Cross-referencing
235    
236     (defun xref-locations (relation name &optional inverse)
237     (delete-duplicates
238     (mapcan #'find-definitions
239     (if inverse
240 heller 1.26 (ccl::get-relation relation name :wild :exhaustive t)
241     (ccl::get-relation relation :wild name :exhaustive t)))
242 heller 1.1 :test 'equal))
243    
244     (defimplementation who-binds (name)
245     (xref-locations :binds name))
246    
247     (defimplementation who-macroexpands (name)
248     (xref-locations :macro-calls name t))
249    
250     (defimplementation who-references (name)
251     (remove-duplicates
252     (append (xref-locations :references name)
253     (xref-locations :sets name)
254     (xref-locations :binds name))
255     :test 'equal))
256    
257     (defimplementation who-sets (name)
258     (xref-locations :sets name))
259    
260     (defimplementation who-calls (name)
261     (remove-duplicates
262     (append
263     (xref-locations :direct-calls name)
264     (xref-locations :indirect-calls name)
265     (xref-locations :macro-calls name t))
266     :test 'equal))
267    
268     (defimplementation who-specializes (class)
269 trittweiler 1.8 (when (symbolp class)
270     (setq class (find-class class nil)))
271     (when class
272     (delete-duplicates
273     (mapcar (lambda (m)
274     (car (find-definitions m)))
275     (ccl:specializer-direct-methods class))
276     :test 'equal)))
277 heller 1.1
278     (defimplementation list-callees (name)
279     (remove-duplicates
280     (append
281     (xref-locations :direct-calls name t)
282     (xref-locations :macro-calls name nil))
283     :test 'equal))
284    
285     (defimplementation list-callers (symbol)
286     (delete-duplicates
287     (mapcan #'find-definitions (ccl:caller-functions symbol))
288     :test #'equal))
289    
290     ;;; Profiling (alanr: lifted from swank-clisp)
291    
292     (defimplementation profile (fname)
293     (eval `(mon:monitor ,fname))) ;monitor is a macro
294    
295     (defimplementation profiled-functions ()
296     mon:*monitored-functions*)
297    
298     (defimplementation unprofile (fname)
299     (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
300    
301     (defimplementation unprofile-all ()
302     (mon:unmonitor))
303    
304     (defimplementation profile-report ()
305     (mon:report-monitoring))
306    
307     (defimplementation profile-reset ()
308     (mon:reset-all-monitoring))
309    
310     (defimplementation profile-package (package callers-p methods)
311     (declare (ignore callers-p methods))
312     (mon:monitor-all package))
313    
314     ;;; Debugging
315    
316     (defimplementation call-with-debugging-environment (debugger-loop-fn)
317     (let* (;;(*debugger-hook* nil)
318     ;; don't let error while printing error take us down
319     (ccl:*signal-printing-errors* nil))
320     (funcall debugger-loop-fn)))
321    
322 heller 1.17 ;; This is called for an async interrupt and is running in a random
323     ;; thread not selected by the user, so don't use thread-local vars
324     ;; such as *emacs-connection*.
325 heller 1.1 (defun find-repl-thread ()
326 heller 1.18 (let* ((*break-on-signals* nil)
327     (conn (funcall (swank-sym default-connection))))
328 heller 1.1 (and conn
329 heller 1.18 (ignore-errors ;; this errors if no repl-thread
330     (funcall (swank-sym repl-thread) conn)))))
331    
332 heller 1.1 (defimplementation call-with-debugger-hook (hook fun)
333     (let ((*debugger-hook* hook)
334     (ccl:*break-hook* hook)
335     (ccl:*select-interactive-process-hook* 'find-repl-thread))
336     (funcall fun)))
337    
338     (defimplementation install-debugger-globally (function)
339     (setq *debugger-hook* function)
340     (setq ccl:*break-hook* function)
341     (setq ccl:*select-interactive-process-hook* 'find-repl-thread)
342     )
343    
344     (defun map-backtrace (function &optional
345 sboukarev 1.7 (start-frame-number 0)
346     end-frame-number)
347 heller 1.1 "Call FUNCTION passing information about each stack frame
348     from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
349 sboukarev 1.7 (let ((end-frame-number (or end-frame-number most-positive-fixnum)))
350     (ccl:map-call-frames function
351     :origin ccl:*top-error-frame*
352     :start-frame-number start-frame-number
353 heller 1.18 :count (- end-frame-number start-frame-number))))
354 heller 1.1
355     (defimplementation compute-backtrace (start-frame-number end-frame-number)
356     (let (result)
357     (map-backtrace (lambda (p context)
358     (push (list :frame p context) result))
359     start-frame-number end-frame-number)
360     (nreverse result)))
361    
362     (defimplementation print-frame (frame stream)
363     (assert (eq (first frame) :frame))
364     (destructuring-bind (p context) (rest frame)
365     (let ((lfun (ccl:frame-function p context)))
366     (format stream "(~S" (or (ccl:function-name lfun) lfun))
367     (let* ((unavailable (cons nil nil))
368 heller 1.17 (args (ccl:frame-supplied-arguments p context
369     :unknown-marker unavailable)))
370 heller 1.1 (declare (dynamic-extent unavailable))
371     (if (eq args unavailable)
372 heller 1.17 (format stream " #<Unknown Arguments>")
373     (dolist (arg args)
374     (if (eq arg unavailable)
375     (format stream " #<Unavailable>")
376     (format stream " ~s" arg)))))
377 heller 1.1 (format stream ")"))))
378    
379 sboukarev 1.14 (defmacro with-frame ((p context) frame-number &body body)
380     `(call/frame ,frame-number (lambda (,p ,context) . ,body)))
381    
382 heller 1.1 (defun call/frame (frame-number if-found)
383     (map-backtrace
384     (lambda (p context)
385 sboukarev 1.13 (return-from call/frame
386 heller 1.1 (funcall if-found p context)))
387     frame-number))
388    
389 heller 1.17 (defimplementation frame-call (frame-number)
390     (with-frame (p context) frame-number
391     (with-output-to-string (stream)
392     (print-frame (list :frame p context) stream))))
393 heller 1.1
394     (defimplementation frame-var-value (frame var)
395     (with-frame (p context) frame
396     (cdr (nth var (ccl:frame-named-variables p context)))))
397    
398     (defimplementation frame-locals (index)
399     (with-frame (p context) index
400     (loop for (name . value) in (ccl:frame-named-variables p context)
401     collect (list :name name :value value :id 0))))
402    
403     (defimplementation frame-source-location (index)
404     (with-frame (p context) index
405     (multiple-value-bind (lfun pc) (ccl:frame-function p context)
406     (if pc
407     (pc-source-location lfun pc)
408     (function-source-location lfun)))))
409    
410     (defimplementation eval-in-frame (form index)
411     (with-frame (p context) index
412     (let ((vars (ccl:frame-named-variables p context)))
413     (eval `(let ,(loop for (var . val) in vars collect `(,var ',val))
414     (declare (ignorable ,@(mapcar #'car vars)))
415     ,form)))))
416    
417     (defimplementation return-from-frame (index form)
418     (let ((values (multiple-value-list (eval-in-frame form index))))
419     (with-frame (p context) index
420     (declare (ignore context))
421     (ccl:apply-in-frame p #'values values))))
422    
423     (defimplementation restart-frame (index)
424     (with-frame (p context) index
425     (ccl:apply-in-frame p
426     (ccl:frame-function p context)
427     (ccl:frame-supplied-arguments p context))))
428    
429     (defimplementation disassemble-frame (the-frame-number)
430     (with-frame (p context) the-frame-number
431     (multiple-value-bind (lfun pc) (ccl:frame-function p context)
432     (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context)
433     (disassemble lfun))))
434    
435     ;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008)
436     ;; contains some interesting details:
437     ;;
438     ;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects
439     ;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS,
440     ;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end
441     ;; positions are file positions (not character positions). The text will
442     ;; be NIL unless text recording was on at read-time. If the original
443     ;; file is still available, you can force missing source text to be read
444     ;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.
445     ;;
446     ;; Source-note's are associated with definitions (via record-source-file)
447     ;; and also stored in function objects (including anonymous and nested
448     ;; functions). The former can be retrieved via
449     ;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.
450     ;;
451     ;; The recording behavior is controlled by the new variable
452     ;; CCL:*SAVE-SOURCE-LOCATIONS*:
453     ;;
454     ;; If NIL, don't store source-notes in function objects, and store only
455     ;; the filename for definitions (the latter only if
456     ;; *record-source-file* is true).
457     ;;
458     ;; If T, store source-notes, including a copy of the original source
459     ;; text, for function objects and definitions (the latter only if
460     ;; *record-source-file* is true).
461     ;;
462     ;; If :NO-TEXT, store source-notes, but without saved text, for
463     ;; function objects and defintions (the latter only if
464     ;; *record-source-file* is true). This is the default.
465     ;;
466     ;; PC to source mapping is controlled by the new variable
467     ;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a
468     ;; compressed table mapping pc offsets to corresponding source locations.
469     ;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc)
470     ;; which returns a source-note for the source at offset pc in the
471     ;; function.
472    
473     (defun function-source-location (function)
474     (source-note-to-source-location
475 heller 1.11 (or (ccl:function-source-note function)
476     (function-name-source-note function))
477 heller 1.1 (lambda ()
478     (format nil "Function has no source note: ~A" function))
479     (ccl:function-name function)))
480    
481     (defun pc-source-location (function pc)
482     (source-note-to-source-location
483     (or (ccl:find-source-note-at-pc function pc)
484 heller 1.11 (ccl:function-source-note function)
485     (function-name-source-note function))
486 heller 1.1 (lambda ()
487     (format nil "No source note at PC: ~a[~d]" function pc))
488     (ccl:function-name function)))
489    
490 heller 1.11 (defun function-name-source-note (fun)
491     (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function)))
492     (and defs
493     (destructuring-bind ((type . name) srcloc . srclocs) (car defs)
494     (declare (ignore type name srclocs))
495     srcloc))))
496    
497 heller 1.1 (defun source-note-to-source-location (source if-nil-thunk &optional name)
498     (labels ((filename-to-buffer (filename)
499     (cond ((gethash filename *temp-file-map*)
500     (list :buffer (gethash filename *temp-file-map*)))
501     ((probe-file filename)
502 heller 1.17 (list :file (ccl:native-translated-namestring
503     (truename filename))))
504 heller 1.1 (t (error "File ~s doesn't exist" filename)))))
505     (handler-case
506     (cond ((ccl:source-note-p source)
507     (let* ((full-text (ccl:source-note-text source))
508     (file-name (ccl:source-note-filename source))
509     (start-pos (ccl:source-note-start-pos source)))
510     (make-location
511 sboukarev 1.2 (when file-name (filename-to-buffer (pathname file-name)))
512 heller 1.1 (when start-pos (list :position (1+ start-pos)))
513 heller 1.17 (when full-text
514     (list :snippet (subseq full-text 0
515     (min 40 (length full-text))))))))
516 heller 1.1 ((and source name)
517 heller 1.17 ;; This branch is probably never used
518 heller 1.1 (make-location
519     (filename-to-buffer source)
520 heller 1.17 (list :function-name (princ-to-string
521     (if (functionp name)
522     (ccl:function-name name)
523     name)))))
524 heller 1.1 (t `(:error ,(funcall if-nil-thunk))))
525     (error (c) `(:error ,(princ-to-string c))))))
526    
527 heller 1.6 (defimplementation find-definitions (name)
528     (let ((defs (or (ccl:find-definition-sources name)
529     (and (symbolp name)
530     (fboundp name)
531     (ccl:find-definition-sources (symbol-function name))))))
532     (loop for ((type . name) . sources) in defs
533     collect (list (definition-name type name)
534     (source-note-to-source-location
535     (find-if-not #'null sources)
536     (lambda () "No source-note available")
537     name)))))
538 heller 1.1
539     (defimplementation find-source-location (obj)
540     (let* ((defs (ccl:find-definition-sources obj))
541     (best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal)
542     (car defs)))
543     (note (find-if-not #'null (cdr best-def))))
544     (when note
545     (source-note-to-source-location
546     note
547     (lambda () "No source note available")))))
548    
549     (defun definition-name (type object)
550 heller 1.4 (case (ccl:definition-type-name type)
551     (method (ccl:name-of object))
552     (t (list (ccl:definition-type-name type) (ccl:name-of object)))))
553 heller 1.1
554     ;;; Utilities
555    
556     (defimplementation describe-symbol-for-emacs (symbol)
557     (let ((result '()))
558     (flet ((doc (kind &optional (sym symbol))
559     (or (documentation sym kind) :not-documented))
560     (maybe-push (property value)
561     (when value
562     (setf result (list* property value result)))))
563     (maybe-push
564     :variable (when (boundp symbol)
565     (doc 'variable)))
566     (maybe-push
567     :function (if (fboundp symbol)
568     (doc 'function)))
569     (maybe-push
570     :setf (let ((setf-function-name (ccl:setf-function-spec-name
571     `(setf ,symbol))))
572     (when (fboundp setf-function-name)
573     (doc 'function setf-function-name))))
574     (maybe-push
575     :type (when (ccl:type-specifier-p symbol)
576     (doc 'type)))
577     result)))
578    
579     (defimplementation describe-definition (symbol namespace)
580     (ecase namespace
581     (:variable
582     (describe symbol))
583     ((:function :generic-function)
584     (describe (symbol-function symbol)))
585     (:setf
586     (describe (ccl:setf-function-spec-name `(setf ,symbol))))
587     (:class
588     (describe (find-class symbol)))
589     (:type
590     (describe (or (find-class symbol nil) symbol)))))
591    
592     (defimplementation toggle-trace (spec)
593     "We currently ignore just about everything."
594     (ecase (car spec)
595     (setf
596     (ccl:trace-function spec))
597     ((:defgeneric)
598     (ccl:trace-function (second spec)))
599     ((:defmethod)
600     (destructuring-bind (name qualifiers specializers) (cdr spec)
601     (ccl:trace-function
602     (find-method (fdefinition name) qualifiers specializers)))))
603     t)
604    
605     ;;; Macroexpansion
606    
607     (defimplementation macroexpand-all (form)
608     (ccl:macroexpand-all form))
609    
610     ;;;; Inspection
611    
612     (defun comment-type-p (type)
613     (or (eq type :comment)
614     (and (consp type) (eq (car type) :comment))))
615    
616     (defmethod emacs-inspect ((o t))
617     (let* ((inspector:*inspector-disassembly* t)
618     (i (inspector:make-inspector o))
619     (count (inspector:compute-line-count i)))
620     (loop for l from 0 below count append
621     (multiple-value-bind (value label type) (inspector:line-n i l)
622     (etypecase type
623     ((member nil :normal)
624     `(,(or label "") (:value ,value) (:newline)))
625     ((member :colon)
626     (label-value-line label value))
627     ((member :static)
628     (list (princ-to-string label) " " `(:value ,value) '(:newline)))
629     ((satisfies comment-type-p)
630     (list (princ-to-string label) '(:newline))))))))
631    
632     (defmethod emacs-inspect :around ((o t))
633     (if (or (uvector-inspector-p o)
634     (not (ccl:uvectorp o)))
635     (call-next-method)
636     (let ((value (call-next-method)))
637     (cond ((listp value)
638     (append value
639     `((:newline)
640     (:value ,(make-instance 'uvector-inspector :object o)
641     "Underlying UVECTOR"))))
642     (t value)))))
643    
644 sboukarev 1.19 (defmethod emacs-inspect ((f function))
645     (append
646     (label-value-line "Name" (function-name f))
647     `("Its argument list is: "
648     ,(princ-to-string (arglist f)) (:newline))
649     (label-value-line "Documentation" (documentation f t))
650     (when (function-lambda-expression f)
651     (label-value-line "Lambda Expression"
652     (function-lambda-expression f)))
653     (when (ccl:function-source-note f)
654     (label-value-line "Source note"
655     (ccl:function-source-note f)))
656     (when (typep f 'ccl:compiled-lexical-closure)
657     (append
658     (label-value-line "Inner function" (ccl::closure-function f))
659     '("Closed over values:" (:newline))
660     (loop for (name value) in (ccl::closure-closed-over-values f)
661     append (label-value-line (format nil " ~a" name)
662     value))))))
663    
664 heller 1.1 (defclass uvector-inspector ()
665     ((object :initarg :object)))
666    
667     (defgeneric uvector-inspector-p (object)
668     (:method ((object t)) nil)
669     (:method ((object uvector-inspector)) t))
670    
671     (defmethod emacs-inspect ((uv uvector-inspector))
672     (with-slots (object) uv
673     (loop for i below (ccl:uvsize object) append
674     (label-value-line (princ-to-string i) (ccl:uvref object i)))))
675    
676     ;;; Multiprocessing
677    
678     (defvar *known-processes*
679     (make-hash-table :size 20 :weak :key :test #'eq)
680     "A map from threads to mailboxes.")
681    
682     (defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*"))
683    
684     (defstruct (mailbox (:conc-name mailbox.))
685     (mutex (ccl:make-lock "thread mailbox"))
686     (semaphore (ccl:make-semaphore))
687     (queue '() :type list))
688    
689     (defimplementation spawn (fun &key name)
690 sboukarev 1.22 (ccl:process-run-function (or name "Anonymous (Swank)")
691 heller 1.11 fun))
692    
693 heller 1.1 (defimplementation thread-id (thread)
694     (ccl:process-serial-number thread))
695    
696     (defimplementation find-thread (id)
697     (find id (ccl:all-processes) :key #'ccl:process-serial-number))
698    
699     (defimplementation thread-name (thread)
700     (ccl:process-name thread))
701    
702     (defimplementation thread-status (thread)
703     (format nil "~A" (ccl:process-whostate thread)))
704    
705     (defimplementation thread-attributes (thread)
706     (list :priority (ccl:process-priority thread)))
707    
708     (defimplementation make-lock (&key name)
709     (ccl:make-lock name))
710    
711     (defimplementation call-with-lock-held (lock function)
712     (ccl:with-lock-grabbed (lock)
713     (funcall function)))
714    
715     (defimplementation current-thread ()
716     ccl:*current-process*)
717    
718     (defimplementation all-threads ()
719     (ccl:all-processes))
720    
721     (defimplementation kill-thread (thread)
722 heller 1.10 ;;(ccl:process-kill thread) ; doesn't cut it
723     (ccl::process-initial-form-exited thread :kill))
724 heller 1.1
725     (defimplementation thread-alive-p (thread)
726     (not (ccl:process-exhausted-p thread)))
727    
728     (defimplementation interrupt-thread (thread function)
729     (ccl:process-interrupt
730     thread
731     (lambda ()
732     (let ((ccl:*top-error-frame* (ccl::%current-exception-frame)))
733     (funcall function)))))
734    
735     (defun mailbox (thread)
736     (ccl:with-lock-grabbed (*known-processes-lock*)
737     (or (gethash thread *known-processes*)
738     (setf (gethash thread *known-processes*) (make-mailbox)))))
739    
740     (defimplementation send (thread message)
741     (assert message)
742     (let* ((mbox (mailbox thread))
743     (mutex (mailbox.mutex mbox)))
744     (ccl:with-lock-grabbed (mutex)
745     (setf (mailbox.queue mbox)
746     (nconc (mailbox.queue mbox) (list message)))
747     (ccl:signal-semaphore (mailbox.semaphore mbox)))))
748    
749     (defimplementation receive-if (test &optional timeout)
750     (let* ((mbox (mailbox ccl:*current-process*))
751     (mutex (mailbox.mutex mbox)))
752     (assert (or (not timeout) (eq timeout t)))
753     (loop
754     (check-slime-interrupts)
755     (ccl:with-lock-grabbed (mutex)
756     (let* ((q (mailbox.queue mbox))
757     (tail (member-if test q)))
758     (when tail
759     (setf (mailbox.queue mbox)
760     (nconc (ldiff q tail) (cdr tail)))
761     (return (car tail)))))
762     (when (eq timeout t) (return (values nil t)))
763     (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))
764    
765 heller 1.25 (let ((alist '())
766     (lock (ccl:make-lock "register-thread")))
767    
768     (defimplementation register-thread (name thread)
769     (declare (type symbol name))
770     (ccl:with-lock-grabbed (lock)
771     (etypecase thread
772     (null
773     (setf alist (delete name alist :key #'car)))
774     (ccl:process
775     (let ((probe (assoc name alist)))
776     (cond (probe (setf (cdr probe) thread))
777     (t (setf alist (acons name thread alist))))))))
778     nil)
779    
780     (defimplementation find-registered (name)
781     (ccl:with-lock-grabbed (lock)
782     (cdr (assoc name alist)))))
783    
784 heller 1.1 (defimplementation set-default-initial-binding (var form)
785     (eval `(ccl::def-standard-initial-binding ,var ,form)))
786    
787     (defimplementation quit-lisp ()
788     (ccl:quit))
789    
790     ;;; Weak datastructures
791    
792     (defimplementation make-weak-key-hash-table (&rest args)
793     (apply #'make-hash-table :weak :key args))
794    
795     (defimplementation make-weak-value-hash-table (&rest args)
796     (apply #'make-hash-table :weak :value args))
797    
798     (defimplementation hash-table-weakness (hashtable)
799     (ccl:hash-table-weak-p hashtable))
800 sboukarev 1.29
801     (pushnew 'deinit-log-output ccl:*save-exit-functions*)

  ViewVC Help
Powered by ViewVC 1.1.5