/[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.8 by trittweiler, Sat Oct 24 11:32:18 2009 UTC revision 1.23 by heller, Sun Nov 6 17:04:32 2011 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 127  Line 82 
82    (let ((str (symbol-name sym)))    (let ((str (symbol-name sym)))
83      `(or (find-symbol ,str :swank)      `(or (find-symbol ,str :swank)
84           (error "There is no symbol named ~a in the SWANK package" ,str))))           (error "There is no symbol named ~a in the SWANK package" ,str))))
85    ;;; UTF8
86    
87    (defimplementation string-to-utf8 (string)
88      (ccl:encode-string-to-octets string :external-format :utf-8))
89    
90    (defimplementation utf8-to-string (octets)
91      (ccl:decode-string-from-octets octets :external-format :utf-8))
92    
93  ;;; TCP Server  ;;; TCP Server
94    
# Line 145  Line 106 
106    (close socket))    (close socket))
107    
108  (defimplementation accept-connection (socket &key external-format  (defimplementation accept-connection (socket &key external-format
109                                               buffering timeout)                                        buffering timeout)
110    (declare (ignore buffering timeout))    (declare (ignore buffering timeout))
111    (ccl:accept-connection socket :wait t    (let ((stream-args (and external-format
112                           :stream-args (and external-format                            `(:external-format ,external-format))))
113                                             `(:external-format ,external-format))))      (ccl:accept-connection socket :wait t :stream-args stream-args)))
114    
115  (defvar *external-format-to-coding-system*  (defvar *external-format-to-coding-system*
116    '((:iso-8859-1    '((:iso-8859-1
# Line 161  Line 122 
122    (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))    (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
123                    *external-format-to-coding-system*)))                    *external-format-to-coding-system*)))
124    
125  ;;; Unix signals  (defimplementation socket-fd (stream)
126      (ccl::ioblock-device (ccl::stream-ioblock stream t)))
127    
128  (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)))  
129    
130  (defimplementation getpid ()  (defimplementation getpid ()
131    (ccl::getpid))    (ccl::getpid))
# Line 226  Line 184 
184        (funcall function))))        (funcall function))))
185    
186  (defimplementation swank-compile-file (input-file output-file  (defimplementation swank-compile-file (input-file output-file
187                                         load-p external-format)                                         load-p external-format
188                                           &key policy)
189      (declare (ignore policy))
190    (with-compilation-hooks ()    (with-compilation-hooks ()
191      (compile-file input-file      (compile-file input-file
192                    :output-file output-file                    :output-file output-file
193                    :load load-p                    :load load-p
194                    :external-format external-format)))                    :external-format external-format)))
195    
196  ;; 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
197  ;; as compile-time.  ;; eval-when's as compile-time.
198  (defimplementation swank-compile-string (string &key buffer position filename  (defimplementation swank-compile-string (string &key buffer position filename
199                                           policy)                                           policy)
200    (declare (ignore policy))    (declare (ignore policy))
# Line 350  Line 310 
310    
311  ;;; Debugging  ;;; Debugging
312    
 (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))  
   
313  (defimplementation call-with-debugging-environment (debugger-loop-fn)  (defimplementation call-with-debugging-environment (debugger-loop-fn)
314    (let* (;;(*debugger-hook* nil)    (let* (;;(*debugger-hook* nil)
315           ;; don't let error while printing error take us down           ;; don't let error while printing error take us down
316           (ccl:*signal-printing-errors* nil))           (ccl:*signal-printing-errors* nil))
317      (funcall debugger-loop-fn)))      (funcall debugger-loop-fn)))
318    
319    ;; This is called for an async interrupt and is running in a random
320    ;; thread not selected by the user, so don't use thread-local vars
321    ;; such as *emacs-connection*.
322  (defun find-repl-thread ()  (defun find-repl-thread ()
323    ;; This is called for an async interrupt and is running in a random thread not    (let* ((*break-on-signals* nil)
324    ;; 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))))  
325      (and conn      (and conn
326           (let ((*break-on-signals* nil))           (ignore-errors ;; this errors if no repl-thread
327             (ignore-errors ;; this errors if no repl-thread             (funcall (swank-sym repl-thread) conn)))))
328               (funcall (swank-sym repl-thread) conn))))))  
   
329  (defimplementation call-with-debugger-hook (hook fun)  (defimplementation call-with-debugger-hook (hook fun)
330    (let ((*debugger-hook* hook)    (let ((*debugger-hook* hook)
331          (ccl:*break-hook* hook)          (ccl:*break-hook* hook)
# Line 396  Line 347 
347      (ccl:map-call-frames function      (ccl:map-call-frames function
348                           :origin ccl:*top-error-frame*                           :origin ccl:*top-error-frame*
349                           :start-frame-number start-frame-number                           :start-frame-number start-frame-number
350                           :count (- end-frame-number start-frame-number)                           :count (- end-frame-number start-frame-number))))
                          :test (and (not t) ;(not (symbol-value (swank-sym *sldb-show-internal-frames*)))  
                                     '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))))  
   
351    
352  (defimplementation compute-backtrace (start-frame-number end-frame-number)  (defimplementation compute-backtrace (start-frame-number end-frame-number)
353    (let (result)    (let (result)
# Line 438  Line 362 
362      (let ((lfun (ccl:frame-function p context)))      (let ((lfun (ccl:frame-function p context)))
363        (format stream "(~S" (or (ccl:function-name lfun) lfun))        (format stream "(~S" (or (ccl:function-name lfun) lfun))
364        (let* ((unavailable (cons nil nil))        (let* ((unavailable (cons nil nil))
365              (args (ccl:frame-supplied-arguments p context :unknown-marker unavailable)))               (args (ccl:frame-supplied-arguments p context
366                                                     :unknown-marker unavailable)))
367          (declare (dynamic-extent unavailable))          (declare (dynamic-extent unavailable))
368          (if (eq args unavailable)          (if (eq args unavailable)
369            (format stream " #<Unknown Arguments>")              (format stream " #<Unknown Arguments>")
370            (loop for arg in args              (dolist (arg args)
371                  do (if (eq arg unavailable)                (if (eq arg unavailable)
372                       (format stream " #<Unavailable>")                    (format stream " #<Unavailable>")
373                       (format stream " ~s" arg)))))                    (format stream " ~s" arg)))))
374        (format stream ")"))))        (format stream ")"))))
375    
376    (defmacro with-frame ((p context) frame-number &body body)
377      `(call/frame ,frame-number (lambda (,p ,context) . ,body)))
378    
379  (defun call/frame (frame-number if-found)  (defun call/frame (frame-number if-found)
380    (map-backtrace    (map-backtrace
381     (lambda (p context)     (lambda (p context)
382       (return-from call/frame       (return-from call/frame
383         (funcall if-found p context)))         (funcall if-found p context)))
384     frame-number))     frame-number))
385    
386  (defmacro with-frame ((p context) frame-number &body body)  (defimplementation frame-call (frame-number)
387    `(call/frame ,frame-number (lambda (,p ,context) . ,body)))    (with-frame (p context) frame-number
388        (with-output-to-string (stream)
389          (print-frame (list :frame p context) stream))))
390    
391  (defimplementation frame-var-value (frame var)  (defimplementation frame-var-value (frame var)
392    (with-frame (p context) frame    (with-frame (p context) frame
# Line 499  Line 429 
429        (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)
430        (disassemble lfun))))        (disassemble lfun))))
431    
   
432  ;; 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)
433  ;; contains some interesting details:  ;; contains some interesting details:
434  ;;  ;;
# Line 537  Line 466 
466  ;; 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)
467  ;; 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
468  ;; 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.  
469    
470  (defun function-source-location (function)  (defun function-source-location (function)
471    (source-note-to-source-location    (source-note-to-source-location
472     (ccl:function-source-note function)     (or (ccl:function-source-note function)
473           (function-name-source-note function))
474     (lambda ()     (lambda ()
475       (format nil "Function has no source note: ~A" function))       (format nil "Function has no source note: ~A" function))
476     (ccl:function-name function)))     (ccl:function-name function)))
# Line 553  Line 478 
478  (defun pc-source-location (function pc)  (defun pc-source-location (function pc)
479    (source-note-to-source-location    (source-note-to-source-location
480     (or (ccl:find-source-note-at-pc function pc)     (or (ccl:find-source-note-at-pc function pc)
481         (ccl:function-source-note function))         (ccl:function-source-note function)
482           (function-name-source-note function))
483     (lambda ()     (lambda ()
484       (format nil "No source note at PC: ~a[~d]" function pc))       (format nil "No source note at PC: ~a[~d]" function pc))
485     (ccl:function-name function)))     (ccl:function-name function)))
486    
487    (defun function-name-source-note (fun)
488      (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function)))
489        (and defs
490             (destructuring-bind ((type . name) srcloc . srclocs) (car defs)
491               (declare (ignore type name srclocs))
492               srcloc))))
493    
494  (defun source-note-to-source-location (source if-nil-thunk &optional name)  (defun source-note-to-source-location (source if-nil-thunk &optional name)
495    (labels ((filename-to-buffer (filename)    (labels ((filename-to-buffer (filename)
496               (cond ((gethash filename *temp-file-map*)               (cond ((gethash filename *temp-file-map*)
497                      (list :buffer (gethash filename *temp-file-map*)))                      (list :buffer (gethash filename *temp-file-map*)))
498                     ((probe-file filename)                     ((probe-file filename)
499                      (list :file (ccl:native-translated-namestring (truename filename))))                      (list :file (ccl:native-translated-namestring
500                                     (truename filename))))
501                     (t (error "File ~s doesn't exist" filename)))))                     (t (error "File ~s doesn't exist" filename)))))
502      (handler-case      (handler-case
503          (cond ((ccl:source-note-p source)          (cond ((ccl:source-note-p source)
# Line 573  Line 507 
507                   (make-location                   (make-location
508                    (when file-name (filename-to-buffer (pathname file-name)))                    (when file-name (filename-to-buffer (pathname file-name)))
509                    (when start-pos (list :position (1+ start-pos)))                    (when start-pos (list :position (1+ start-pos)))
510                    (when full-text (list :snippet (subseq full-text  0 (min 40 (length full-text))))))))                    (when full-text
511                        (list :snippet (subseq full-text 0
512                                               (min 40 (length full-text))))))))
513                ((and source name)                ((and source name)
514                   ;; This branch is probably never used
515                 (make-location                 (make-location
516                  (filename-to-buffer source)                  (filename-to-buffer source)
517                  (list :function-name (let ((*package* (find-package :swank-io-package))) ;; should be buffer package.                  (list :function-name (princ-to-string
518                                         (with-standard-io-syntax                                        (if (functionp name)
519                                             (princ-to-string (if (functionp name)                                            (ccl:function-name name)
520                                                                (ccl:function-name name)                                            name)))))
                                                               name)))))))  
521                (t `(:error ,(funcall if-nil-thunk))))                (t `(:error ,(funcall if-nil-thunk))))
522        (error (c) `(:error ,(princ-to-string c))))))        (error (c) `(:error ,(princ-to-string c))))))
523    
# Line 702  Line 638 
638                                   "Underlying UVECTOR"))))                                   "Underlying UVECTOR"))))
639                (t value)))))                (t value)))))
640    
641    (defmethod emacs-inspect ((f function))
642      (append
643       (label-value-line "Name" (function-name f))
644       `("Its argument list is: "
645         ,(princ-to-string (arglist f)) (:newline))
646       (label-value-line "Documentation" (documentation  f t))
647       (when (function-lambda-expression f)
648         (label-value-line "Lambda Expression"
649                           (function-lambda-expression f)))
650       (when (ccl:function-source-note f)
651         (label-value-line "Source note"
652                           (ccl:function-source-note f)))
653       (when (typep f 'ccl:compiled-lexical-closure)
654         (append
655          (label-value-line "Inner function" (ccl::closure-function f))
656          '("Closed over values:" (:newline))
657          (loop for (name value) in (ccl::closure-closed-over-values f)
658                append (label-value-line (format nil " ~a" name)
659                                         value))))))
660    
661  (defclass uvector-inspector ()  (defclass uvector-inspector ()
662    ((object :initarg :object)))    ((object :initarg :object)))
663    
# Line 728  Line 684 
684    (queue '() :type list))    (queue '() :type list))
685    
686  (defimplementation spawn (fun &key name)  (defimplementation spawn (fun &key name)
687    (ccl:process-run-function    (ccl:process-run-function (or name "Anonymous (Swank)")
688     (or name "Anonymous (Swank)")                              fun))
    fun))  
689    
690  (defimplementation thread-id (thread)  (defimplementation thread-id (thread)
691    (ccl:process-serial-number thread))    (ccl:process-serial-number thread))
# Line 761  Line 716 
716    (ccl:all-processes))    (ccl:all-processes))
717    
718  (defimplementation kill-thread (thread)  (defimplementation kill-thread (thread)
719    (ccl:process-kill thread))    ;;(ccl:process-kill thread) ; doesn't cut it
720      (ccl::process-initial-form-exited thread :kill))
721    
722  (defimplementation thread-alive-p (thread)  (defimplementation thread-alive-p (thread)
723    (not (ccl:process-exhausted-p thread)))    (not (ccl:process-exhausted-p thread)))

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.23

  ViewVC Help
Powered by ViewVC 1.1.5