/[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.15 by sboukarev, Sat Feb 20 15:12:19 2010 UTC
# Line 13  Line 13 
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 163  Line 118 
118    
119  ;;; Unix signals  ;;; Unix signals
120    
 (defimplementation call-without-interrupts (fn)  
   ;; 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)))  
   
121  (defimplementation getpid ()  (defimplementation getpid ()
122    (ccl::getpid))    (ccl::getpid))
123    
# Line 448  Line 397 
397                       (format stream " ~s" arg)))))                       (format stream " ~s" arg)))))
398        (format stream ")"))))        (format stream ")"))))
399    
400    (defmacro with-frame ((p context) frame-number &body body)
401      `(call/frame ,frame-number (lambda (,p ,context) . ,body)))
402    
403    (defimplementation frame-call (frame-number)
404      (with-frame (p context) frame-number
405        (with-output-to-string (stream)
406          (print-frame (list :frame p context) stream))))
407    
408  (defun call/frame (frame-number if-found)  (defun call/frame (frame-number if-found)
409    (map-backtrace    (map-backtrace
410     (lambda (p context)     (lambda (p context)
411       (return-from call/frame       (return-from call/frame
412         (funcall if-found p context)))         (funcall if-found p context)))
413     frame-number))     frame-number))
414    
 (defmacro with-frame ((p context) frame-number &body body)  
   `(call/frame ,frame-number (lambda (,p ,context) . ,body)))  
415    
416  (defimplementation frame-var-value (frame var)  (defimplementation frame-var-value (frame var)
417    (with-frame (p context) frame    (with-frame (p context) frame
# Line 545  Line 500 
500    
501  (defun function-source-location (function)  (defun function-source-location (function)
502    (source-note-to-source-location    (source-note-to-source-location
503     (ccl:function-source-note function)     (or (ccl:function-source-note function)
504           (function-name-source-note function))
505     (lambda ()     (lambda ()
506       (format nil "Function has no source note: ~A" function))       (format nil "Function has no source note: ~A" function))
507     (ccl:function-name function)))     (ccl:function-name function)))
# Line 553  Line 509 
509  (defun pc-source-location (function pc)  (defun pc-source-location (function pc)
510    (source-note-to-source-location    (source-note-to-source-location
511     (or (ccl:find-source-note-at-pc function pc)     (or (ccl:find-source-note-at-pc function pc)
512         (ccl:function-source-note function))         (ccl:function-source-note function)
513           (function-name-source-note function))
514     (lambda ()     (lambda ()
515       (format nil "No source note at PC: ~a[~d]" function pc))       (format nil "No source note at PC: ~a[~d]" function pc))
516     (ccl:function-name function)))     (ccl:function-name function)))
517    
518    (defun function-name-source-note (fun)
519      (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function)))
520        (and defs
521             (destructuring-bind ((type . name) srcloc . srclocs) (car defs)
522               (declare (ignore type name srclocs))
523               srcloc))))
524    
525  (defun source-note-to-source-location (source if-nil-thunk &optional name)  (defun source-note-to-source-location (source if-nil-thunk &optional name)
526    (labels ((filename-to-buffer (filename)    (labels ((filename-to-buffer (filename)
527               (cond ((gethash filename *temp-file-map*)               (cond ((gethash filename *temp-file-map*)
# Line 728  Line 692 
692    (queue '() :type list))    (queue '() :type list))
693    
694  (defimplementation spawn (fun &key name)  (defimplementation spawn (fun &key name)
695    (ccl:process-run-function    (ccl:process-run-function (or name "Anonymous (Swank)")
696     (or name "Anonymous (Swank)")                              fun))
    fun))  
697    
698  (defimplementation thread-id (thread)  (defimplementation thread-id (thread)
699    (ccl:process-serial-number thread))    (ccl:process-serial-number thread))
# Line 761  Line 724 
724    (ccl:all-processes))    (ccl:all-processes))
725    
726  (defimplementation kill-thread (thread)  (defimplementation kill-thread (thread)
727    (ccl:process-kill thread))    ;;(ccl:process-kill thread) ; doesn't cut it
728      (ccl::process-initial-form-exited thread :kill))
729    
730  (defimplementation thread-alive-p (thread)  (defimplementation thread-alive-p (thread)
731    (not (ccl:process-exhausted-p thread)))    (not (ccl:process-exhausted-p thread)))

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

  ViewVC Help
Powered by ViewVC 1.1.5