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

Diff of /slime/swank-ccl.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by sboukarev, Mon Jul 27 13:08:17 2009 UTC revision 1.29 by sboukarev, Mon Dec 3 03:43:16 2012 UTC
# Line 1  Line 1 
1  ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-  ;;;; -*- indent-tabs-mode: nil -*-
2  ;;;  ;;;
3  ;;; openmcl-swank.lisp --- SLIME backend for OpenMCL.  ;;; swank-ccl.lisp --- SLIME backend for Clozure CL.
4  ;;;  ;;;
5  ;;; Copyright (C) 2003, James Bielman  <jamesjb@jamesjb.com>  ;;; Copyright (C) 2003, James Bielman  <jamesjb@jamesjb.com>
6  ;;;  ;;;
7  ;;; This program is licensed under the terms of the Lisp Lesser GNU  ;;; This program is licensed under the terms of the Lisp Lesser GNU
8  ;;; Public License, known as the LLGPL, and distributed with OpenMCL  ;;; Public License, known as the LLGPL, and distributed with Clozure CL
9  ;;; as the file "LICENSE".  The LLGPL consists of a preamble and the  ;;; as the file "LICENSE".  The LLGPL consists of a preamble and the
10  ;;; LGPL, which is distributed with OpenMCL as the file "LGPL".  Where  ;;; LGPL, which is distributed with Clozure CL as the file "LGPL".  Where
11  ;;; these conflict, the preamble takes precedence.  ;;; these conflict, the preamble takes precedence.
12  ;;;  ;;;
13  ;;; The LLGPL is also available online at  ;;; The LLGPL is also available online at
14  ;;; http://opensource.franz.com/preamble.html  ;;; http://opensource.franz.com/preamble.html
15    
 ;;;  
 ;;; This is the beginning of a Slime backend for OpenMCL.  It has been  
 ;;; tested only with OpenMCL version 0.14-030901 on Darwin --- I would  
 ;;; be interested in hearing the results with other versions.  
 ;;;  
 ;;; Additionally, reporting the positions of warnings accurately requires  
 ;;; a small patch to the OpenMCL file compiler, which may be found at:  
 ;;;  
 ;;;   http://www.jamesjb.com/slime/openmcl-warning-position.diff  
 ;;;  
 ;;; Things that work:  
 ;;;  
 ;;; * Evaluation of forms with C-M-x.  
 ;;; * Compilation of defuns with C-c C-c.  
 ;;; * File compilation with C-c C-k.  
 ;;; * Most of the debugger functionality, except EVAL-IN-FRAME,  
 ;;;   FRAME-SOURCE-LOCATION, and FRAME-CATCH-TAGS.  
 ;;; * Macroexpanding with C-c RET.  
 ;;; * Disassembling the symbol at point with C-c M-d.  
 ;;; * Describing symbol at point with C-c C-d.  
 ;;; * Compiler warnings are trapped and sent to Emacs using the buffer  
 ;;;   position of the offending top level form.  
 ;;; * Symbol completion and apropos.  
 ;;;  
 ;;; Things that sort of work:  
 ;;;  
 ;;; * WHO-CALLS is implemented but is only able to return the file a  
 ;;;   caller is defined in---source location information is not  
 ;;;   available.  
 ;;;  
 ;;; Things that aren't done yet:  
 ;;;  
 ;;; * Cross-referencing.  
 ;;; * Due to unimplementation functionality the test suite does not  
 ;;;   run correctly (it hangs upon entering the debugger).  
 ;;;  
   
16  (in-package :swank-backend)  (in-package :swank-backend)
17    
 ;; Backward compatibility  
 (eval-when (:compile-toplevel)  
   (unless (fboundp 'ccl:compute-applicable-methods-using-classes)  
     (compile-file (make-pathname :name "swank-openmcl" :type "lisp" :defaults swank-loader::*source-directory*)  
                   :output-file (make-pathname :name "swank-ccl" :defaults swank-loader::*fasl-directory*)  
                   :verbose t)  
     (invoke-restart (find-restart 'ccl::skip-compile-file))))  
   
18  (eval-when (:compile-toplevel :execute :load-toplevel)  (eval-when (:compile-toplevel :execute :load-toplevel)
19    (assert (and (= ccl::*openmcl-major-version* 1)    (assert (and (= ccl::*openmcl-major-version* 1)
20                 (>= ccl::*openmcl-minor-version* 4))                 (>= ccl::*openmcl-minor-version* 4))
# Line 68  Line 23 
23  (import-from :ccl *gray-stream-symbols* :swank-backend)  (import-from :ccl *gray-stream-symbols* :swank-backend)
24    
25  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
26    (require 'xref))    (multiple-value-bind (ok err) (ignore-errors (require 'xref))
27        (unless ok
28          (warn "~a~%" err))))
29    
30  ;;; swank-mop  ;;; swank-mop
31    
# Line 127  Line 84 
84    (let ((str (symbol-name sym)))    (let ((str (symbol-name sym)))
85      `(or (find-symbol ,str :swank)      `(or (find-symbol ,str :swank)
86           (error "There is no symbol named ~a in the SWANK package" ,str))))           (error "There is no symbol named ~a in the SWANK package" ,str))))
87    ;;; UTF8
88    
89    (defimplementation string-to-utf8 (string)
90      (ccl:encode-string-to-octets string :external-format :utf-8))
91    
92    (defimplementation utf8-to-string (octets)
93      (ccl:decode-string-from-octets octets :external-format :utf-8))
94    
95  ;;; TCP Server  ;;; TCP Server
96    
97  (defimplementation preferred-communication-style ()  (defimplementation preferred-communication-style ()
98    :spawn)    :spawn)
99    
100  (defimplementation create-socket (host port)  (defimplementation create-socket (host port &key backlog)
101    (ccl:make-socket :connect :passive :local-port port    (ccl:make-socket :connect :passive :local-port port
102                     :local-host host :reuse-address t))                     :local-host host :reuse-address t
103                       :backlog (or backlog 5)))
104    
105  (defimplementation local-port (socket)  (defimplementation local-port (socket)
106    (ccl:local-port socket))    (ccl:local-port socket))
# Line 145  Line 109 
109    (close socket))    (close socket))
110    
111  (defimplementation accept-connection (socket &key external-format  (defimplementation accept-connection (socket &key external-format
112                                               buffering timeout)                                        buffering timeout)
113    (declare (ignore buffering timeout))    (declare (ignore buffering timeout))
114    (ccl:accept-connection socket :wait t    (let ((stream-args (and external-format
115                           :stream-args (and external-format                            `(:external-format ,external-format))))
116                                             `(:external-format ,external-format))))      (ccl:accept-connection socket :wait t :stream-args stream-args)))
117    
118  (defvar *external-format-to-coding-system*  (defvar *external-format-to-coding-system*
119    '((:iso-8859-1    '((:iso-8859-1
# Line 161  Line 125 
125    (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))    (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
126                    *external-format-to-coding-system*)))                    *external-format-to-coding-system*)))
127    
128  ;;; Unix signals  (defimplementation socket-fd (stream)
129      (ccl::ioblock-device (ccl::stream-ioblock stream t)))
130    
131  (defimplementation call-without-interrupts (fn)  ;;; Unix signals
   ;; This prevents the current thread from being interrupted, but it doesn't  
   ;; keep other threads from running concurrently, so it's not an appropriate  
   ;; replacement for locking.  
   (ccl:without-interrupts (funcall fn)))  
132    
133  (defimplementation getpid ()  (defimplementation getpid ()
134    (ccl::getpid))    (ccl::getpid))
# Line 197  Line 158 
158    
159  (defun handle-compiler-warning (condition)  (defun handle-compiler-warning (condition)
160    "Resignal a ccl:compiler-warning as swank-backend:compiler-warning."    "Resignal a ccl:compiler-warning as swank-backend:compiler-warning."
161    (signal (make-condition    (signal 'compiler-condition
162             'compiler-condition            :original-condition condition
163             :original-condition condition            :message (compiler-warning-short-message condition)
164             :message (format nil "~A" condition)            :source-context nil
165             :short-message (compiler-warning-short-message condition)            :severity (compiler-warning-severity condition)
166             :severity (compiler-warning-severity condition)            :location (source-note-to-source-location
167             :location (source-note-to-source-location                       (ccl:compiler-warning-source-note condition)
168                        (ccl:compiler-warning-source-note condition)                       (lambda () "Unknown source")
169                        (lambda () "Unknown source")                       (ccl:compiler-warning-function-name condition))))
                       (ccl:compiler-warning-function-name condition)))))  
170    
171  (defgeneric compiler-warning-severity (condition))  (defgeneric compiler-warning-severity (condition))
172  (defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning)  (defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning)
# Line 226  Line 186 
186        (funcall function))))        (funcall function))))
187    
188  (defimplementation swank-compile-file (input-file output-file  (defimplementation swank-compile-file (input-file output-file
189                                         load-p external-format)                                         load-p external-format
190                                           &key policy)
191      (declare (ignore policy))
192    (with-compilation-hooks ()    (with-compilation-hooks ()
193      (compile-file input-file      (compile-file input-file
194                    :output-file output-file                    :output-file output-file
195                    :load load-p                    :load load-p
196                    :external-format external-format)))                    :external-format external-format)))
197    
198  ;; Use a temp file rather than in-core compilation in order to handle eval-when's  ;; Use a temp file rather than in-core compilation in order to handle
199  ;; as compile-time.  ;; eval-when's as compile-time.
200  (defimplementation swank-compile-string (string &key buffer position filename  (defimplementation swank-compile-string (string &key buffer position filename
201                                           policy)                                           policy)
202    (declare (ignore policy))    (declare (ignore policy))
# Line 244  Line 206 
206        (unwind-protect        (unwind-protect
207             (progn             (progn
208               (with-open-file (s temp-file-name :direction :output               (with-open-file (s temp-file-name :direction :output
209                                  :if-exists :error)                                  :if-exists :error :external-format :utf-8)
210                 (write-string string s))                 (write-string string s))
211               (let ((binary-filename (compile-temp-file               (let ((binary-filename (compile-temp-file
212                                       temp-file-name filename buffer position)))                                       temp-file-name filename buffer position)))
# Line 263  Line 225 
225                        (setf (gethash temp-file-name *temp-file-map*)                        (setf (gethash temp-file-name *temp-file-map*)
226                              buffer-name)                              buffer-name)
227                        temp-file-name))                        temp-file-name))
228                  :compile-file-original-buffer-offset (1- offset)))                  :compile-file-original-buffer-offset (1- offset)
229                    :external-format :utf-8))
230    
231  (defimplementation save-image (filename &optional restart-function)  (defimplementation save-image (filename &optional restart-function)
232    (ccl:save-application filename :toplevel-function restart-function))    (ccl:save-application filename :toplevel-function restart-function))
# Line 274  Line 237 
237    (delete-duplicates    (delete-duplicates
238     (mapcan #'find-definitions     (mapcan #'find-definitions
239             (if inverse             (if inverse
240               (ccl:get-relation relation name :wild :exhaustive t)               (ccl::get-relation relation name :wild :exhaustive t)
241               (ccl:get-relation relation :wild name :exhaustive t)))               (ccl::get-relation relation :wild name :exhaustive t)))
242     :test 'equal))     :test 'equal))
243    
244  (defimplementation who-binds (name)  (defimplementation who-binds (name)
# Line 303  Line 266 
266     :test 'equal))     :test 'equal))
267    
268  (defimplementation who-specializes (class)  (defimplementation who-specializes (class)
269    (delete-duplicates    (when (symbolp class)
270     (mapcar (lambda (m)      (setq class (find-class class nil)))
271               (car (find-definitions m)))    (when class
272             (ccl:specializer-direct-methods (if (symbolp class) (find-class class) class)))      (delete-duplicates
273     :test 'equal))       (mapcar (lambda (m)
274                   (car (find-definitions m)))
275                 (ccl:specializer-direct-methods class))
276         :test 'equal)))
277    
278  (defimplementation list-callees (name)  (defimplementation list-callees (name)
279    (remove-duplicates    (remove-duplicates
# Line 347  Line 313 
313    
314  ;;; Debugging  ;;; Debugging
315    
 (defun openmcl-set-debug-switches ()  
   (setq ccl:*fasl-save-definitions* nil)  
   (setq ccl:*fasl-save-doc-strings* t)  
   (setq ccl:*fasl-save-local-symbols* t)  
   (setq ccl:*save-arglist-info* t)  
   (setq ccl:*save-definitions* nil)  
   (setq ccl:*save-doc-strings* t)  
   (setq ccl:*save-local-symbols* t)  
   (ccl:start-xref))  
   
316  (defimplementation call-with-debugging-environment (debugger-loop-fn)  (defimplementation call-with-debugging-environment (debugger-loop-fn)
317    (let* (;;(*debugger-hook* nil)    (let* (;;(*debugger-hook* nil)
318           ;; don't let error while printing error take us down           ;; don't let error while printing error take us down
319           (ccl:*signal-printing-errors* nil))           (ccl:*signal-printing-errors* nil))
320      (funcall debugger-loop-fn)))      (funcall debugger-loop-fn)))
321    
322    ;; 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  (defun find-repl-thread ()  (defun find-repl-thread ()
326    ;; This is called for an async interrupt and is running in a random thread not    (let* ((*break-on-signals* nil)
327    ;; selected by the user, so don't use thread-local vars such as *emacs-connection*.           (conn (funcall (swank-sym default-connection))))
   (let* ((conn (funcall (swank-sym default-connection))))  
328      (and conn      (and conn
329           (let ((*break-on-signals* nil))           (ignore-errors ;; this errors if no repl-thread
330             (ignore-errors ;; this errors if no repl-thread             (funcall (swank-sym repl-thread) conn)))))
331               (funcall (swank-sym repl-thread) conn))))))  
   
332  (defimplementation call-with-debugger-hook (hook fun)  (defimplementation call-with-debugger-hook (hook fun)
333    (let ((*debugger-hook* hook)    (let ((*debugger-hook* hook)
334          (ccl:*break-hook* hook)          (ccl:*break-hook* hook)
# Line 384  Line 341 
341    (setq ccl:*select-interactive-process-hook* 'find-repl-thread)    (setq ccl:*select-interactive-process-hook* 'find-repl-thread)
342    )    )
343    
 (let ((ccl::*warn-if-redefine-kernel* nil))  
   ;; Everybody (error, cerror, break, invoke-debugger, and async interrupts) ends up  
   ;; in CCL::BREAK-LOOP, which implements the default debugger. Regardless of how it  
   ;; was entered, make sure it runs with the swank connection state established so  
   ;; that i/o happens via emacs and there is no contention for the terminal (stdin).  
   (ccl:advise  
    ccl::break-loop  
    (if (symbol-value (swank-sym *emacs-connection*))  
      (:do-it)  
      (let ((conn (funcall (swank-sym default-connection))))  
        (if conn  
          (funcall (swank-sym call-with-connection) conn  
                   (lambda () (:do-it)))  
          (:do-it))))  
    :when :around  
    :name swank-default-debugger-context))  
   
344  (defun map-backtrace (function &optional  (defun map-backtrace (function &optional
345                                 (start-frame-number 0)                        (start-frame-number 0)
346                                 (end-frame-number most-positive-fixnum))                        end-frame-number)
347    "Call FUNCTION passing information about each stack frame    "Call FUNCTION passing information about each stack frame
348   from frames START-FRAME-NUMBER to END-FRAME-NUMBER."   from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
349    (ccl:map-call-frames function    (let ((end-frame-number (or end-frame-number most-positive-fixnum)))
350                         :origin ccl:*top-error-frame*      (ccl:map-call-frames function
351                         :start-frame-number start-frame-number                           :origin ccl:*top-error-frame*
352                         :count (- end-frame-number start-frame-number)                           :start-frame-number start-frame-number
353                         :test (and (not t) ;(not (symbol-value (swank-sym *sldb-show-internal-frames*)))                           :count (- end-frame-number start-frame-number))))
                                   'interesting-frame-p)))  
   
 ;; Exceptions  
 (defvar *interesting-internal-frames* ())  
   
 (defun interesting-frame-p (p context)  
   ;; A frame is interesting if it has at least one external symbol in its name.  
   (labels ((internal (obj)  
              ;; For a symbol, return true if the symbol is internal, i.e. not  
              ;; declared to be external.  For a cons or list, everything  
              ;; must be internal.  For a method, the name must be internal.  
              ;; Nothing else is internal.  
              (typecase obj  
                (cons (and (internal (car obj)) (internal (cdr obj))))  
                (symbol (and (eq (symbol-package obj) (find-package :ccl))  
                             (eq :internal (nth-value 1 (find-symbol (symbol-name obj) :ccl)))  
                             (not (member obj *interesting-internal-frames*))))  
                (method (internal (ccl:method-name obj)))  
                (t nil))))  
     (let* ((lfun (ccl:frame-function p context))  
            (internal-frame-p (internal (ccl:function-name lfun))))  
       #+debug (format t "~S is ~@[not ~]internal~%"  
                       (ccl:function-name lfun)  
                       (not internal-frame-p))  
       (not internal-frame-p))))  
   
354    
355  (defimplementation compute-backtrace (start-frame-number end-frame-number)  (defimplementation compute-backtrace (start-frame-number end-frame-number)
356    (let (result)    (let (result)
# Line 451  Line 365 
365      (let ((lfun (ccl:frame-function p context)))      (let ((lfun (ccl:frame-function p context)))
366        (format stream "(~S" (or (ccl:function-name lfun) lfun))        (format stream "(~S" (or (ccl:function-name lfun) lfun))
367        (let* ((unavailable (cons nil nil))        (let* ((unavailable (cons nil nil))
368              (args (ccl:frame-supplied-arguments p context :unknown-marker unavailable)))               (args (ccl:frame-supplied-arguments p context
369                                                     :unknown-marker unavailable)))
370          (declare (dynamic-extent unavailable))          (declare (dynamic-extent unavailable))
371          (if (eq args unavailable)          (if (eq args unavailable)
372            (format stream " #<Unknown Arguments>")              (format stream " #<Unknown Arguments>")
373            (loop for arg in args              (dolist (arg args)
374                  do (if (eq arg unavailable)                (if (eq arg unavailable)
375                       (format stream " #<Unavailable>")                    (format stream " #<Unavailable>")
376                       (format stream " ~s" arg)))))                    (format stream " ~s" arg)))))
377        (format stream ")"))))        (format stream ")"))))
378    
379    (defmacro with-frame ((p context) frame-number &body body)
380      `(call/frame ,frame-number (lambda (,p ,context) . ,body)))
381    
382  (defun call/frame (frame-number if-found)  (defun call/frame (frame-number if-found)
383    (map-backtrace    (map-backtrace
384     (lambda (p context)     (lambda (p context)
385       (return-from call/frame       (return-from call/frame
386         (funcall if-found p context)))         (funcall if-found p context)))
387     frame-number))     frame-number))
388    
389  (defmacro with-frame ((p context) frame-number &body body)  (defimplementation frame-call (frame-number)
390    `(call/frame ,frame-number (lambda (,p ,context) . ,body)))    (with-frame (p context) frame-number
391        (with-output-to-string (stream)
392          (print-frame (list :frame p context) stream))))
393    
394  (defimplementation frame-var-value (frame var)  (defimplementation frame-var-value (frame var)
395    (with-frame (p context) frame    (with-frame (p context) frame
# Line 512  Line 432 
432        (format t "LFUN: ~a~%PC: ~a  FP: #x~x  CONTEXT: ~a~%" lfun pc p context)        (format t "LFUN: ~a~%PC: ~a  FP: #x~x  CONTEXT: ~a~%" lfun pc p context)
433        (disassemble lfun))))        (disassemble lfun))))
434    
   
435  ;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008)  ;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008)
436  ;; contains some interesting details:  ;; contains some interesting details:
437  ;;  ;;
# Line 550  Line 469 
469  ;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc)  ;; 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  ;; which returns a source-note for the source at offset pc in the
471  ;; function.  ;; function.
 ;;  
 ;; Currently the only thing that makes use of any of this is the  
 ;; disassembler.  ILISP and current version of Slime still use  
 ;; backward-compatible functions that deal with filenames only.  The plan  
 ;; is to make Slime, and our IDE, use this eventually.  
472    
473  (defun function-source-location (function)  (defun function-source-location (function)
474    (source-note-to-source-location    (source-note-to-source-location
475     (ccl:function-source-note function)     (or (ccl:function-source-note function)
476           (function-name-source-note function))
477     (lambda ()     (lambda ()
478       (format nil "Function has no source note: ~A" function))       (format nil "Function has no source note: ~A" function))
479     (ccl:function-name function)))     (ccl:function-name function)))
# Line 566  Line 481 
481  (defun pc-source-location (function pc)  (defun pc-source-location (function pc)
482    (source-note-to-source-location    (source-note-to-source-location
483     (or (ccl:find-source-note-at-pc function pc)     (or (ccl:find-source-note-at-pc function pc)
484         (ccl:function-source-note function))         (ccl:function-source-note function)
485           (function-name-source-note function))
486     (lambda ()     (lambda ()
487       (format nil "No source note at PC: ~a[~d]" function pc))       (format nil "No source note at PC: ~a[~d]" function pc))
488     (ccl:function-name function)))     (ccl:function-name function)))
489    
490    (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  (defun source-note-to-source-location (source if-nil-thunk &optional name)  (defun source-note-to-source-location (source if-nil-thunk &optional name)
498    (labels ((filename-to-buffer (filename)    (labels ((filename-to-buffer (filename)
499               (cond ((gethash filename *temp-file-map*)               (cond ((gethash filename *temp-file-map*)
500                      (list :buffer (gethash filename *temp-file-map*)))                      (list :buffer (gethash filename *temp-file-map*)))
501                     ((probe-file filename)                     ((probe-file filename)
502                      (list :file (ccl:native-translated-namestring (truename filename))))                      (list :file (ccl:native-translated-namestring
503                                     (truename filename))))
504                     (t (error "File ~s doesn't exist" filename)))))                     (t (error "File ~s doesn't exist" filename)))))
505      (handler-case      (handler-case
506          (cond ((ccl:source-note-p source)          (cond ((ccl:source-note-p source)
# Line 586  Line 510 
510                   (make-location                   (make-location
511                    (when file-name (filename-to-buffer (pathname file-name)))                    (when file-name (filename-to-buffer (pathname file-name)))
512                    (when start-pos (list :position (1+ start-pos)))                    (when start-pos (list :position (1+ start-pos)))
513                    (when full-text (list :snippet (subseq full-text  0 (min 40 (length full-text))))))))                    (when full-text
514                        (list :snippet (subseq full-text 0
515                                               (min 40 (length full-text))))))))
516                ((and source name)                ((and source name)
517                   ;; This branch is probably never used
518                 (make-location                 (make-location
519                  (filename-to-buffer source)                  (filename-to-buffer source)
520                  (list :function-name (let ((*package* (find-package :swank-io-package))) ;; should be buffer package.                  (list :function-name (princ-to-string
521                                         (with-standard-io-syntax                                        (if (functionp name)
522                                             (princ-to-string (if (functionp name)                                            (ccl:function-name name)
523                                                                (ccl:function-name name)                                            name)))))
                                                               name)))))))  
524                (t `(:error ,(funcall if-nil-thunk))))                (t `(:error ,(funcall if-nil-thunk))))
525        (error (c) `(:error ,(princ-to-string c))))))        (error (c) `(:error ,(princ-to-string c))))))
526    
527  (defimplementation find-definitions (obj)  (defimplementation find-definitions (name)
528    (loop for ((type . name) . sources) in (ccl:find-definition-sources obj)    (let ((defs (or (ccl:find-definition-sources name)
529          collect (list (definition-name type name)                    (and (symbolp name)
530                        (source-note-to-source-location                         (fboundp name)
531                         (find-if-not #'null sources)                         (ccl:find-definition-sources (symbol-function name))))))
532                         (lambda () "No source-note available")      (loop for ((type . name) . sources) in defs
533                         name))))            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    
539  (defimplementation find-source-location (obj)  (defimplementation find-source-location (obj)
540    (let* ((defs (ccl:find-definition-sources obj))    (let* ((defs (ccl:find-definition-sources obj))
# Line 617  Line 547 
547         (lambda () "No source note available")))))         (lambda () "No source note available")))))
548    
549  (defun definition-name (type object)  (defun definition-name (type object)
550    (list (ccl:definition-type-name type) (ccl:name-of object)))    (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    
554  ;;; Utilities  ;;; Utilities
555    
# Line 709  Line 641 
641                                   "Underlying UVECTOR"))))                                   "Underlying UVECTOR"))))
642                (t value)))))                (t value)))))
643    
644    (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  (defclass uvector-inspector ()  (defclass uvector-inspector ()
665    ((object :initarg :object)))    ((object :initarg :object)))
666    
# Line 735  Line 687 
687    (queue '() :type list))    (queue '() :type list))
688    
689  (defimplementation spawn (fun &key name)  (defimplementation spawn (fun &key name)
690    (ccl:process-run-function    (ccl:process-run-function (or name "Anonymous (Swank)")
691     (or name "Anonymous (Swank)")                              fun))
    fun))  
692    
693  (defimplementation thread-id (thread)  (defimplementation thread-id (thread)
694    (ccl:process-serial-number thread))    (ccl:process-serial-number thread))
# Line 768  Line 719 
719    (ccl:all-processes))    (ccl:all-processes))
720    
721  (defimplementation kill-thread (thread)  (defimplementation kill-thread (thread)
722    (ccl:process-kill thread))    ;;(ccl:process-kill thread) ; doesn't cut it
723      (ccl::process-initial-form-exited thread :kill))
724    
725  (defimplementation thread-alive-p (thread)  (defimplementation thread-alive-p (thread)
726    (not (ccl:process-exhausted-p thread)))    (not (ccl:process-exhausted-p thread)))
# Line 810  Line 762 
762       (when (eq timeout t) (return (values nil t)))       (when (eq timeout t) (return (values nil t)))
763       (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))       (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))
764    
765    (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  (defimplementation set-default-initial-binding (var form)  (defimplementation set-default-initial-binding (var form)
785    (eval `(ccl::def-standard-initial-binding ,var ,form)))    (eval `(ccl::def-standard-initial-binding ,var ,form)))
786    
# Line 826  Line 797 
797    
798  (defimplementation hash-table-weakness (hashtable)  (defimplementation hash-table-weakness (hashtable)
799    (ccl:hash-table-weak-p hashtable))    (ccl:hash-table-weak-p hashtable))
800    
801    (pushnew 'deinit-log-output ccl:*save-exit-functions*)

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.29

  ViewVC Help
Powered by ViewVC 1.1.5