/[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.17 by heller, Fri Mar 5 17:45:26 2010 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 128  Line 83 
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    
   
86  ;;; TCP Server  ;;; TCP Server
87    
88  (defimplementation preferred-communication-style ()  (defimplementation preferred-communication-style ()
# Line 145  Line 99 
99    (close socket))    (close socket))
100    
101  (defimplementation accept-connection (socket &key external-format  (defimplementation accept-connection (socket &key external-format
102                                               buffering timeout)                                        buffering timeout)
103    (declare (ignore buffering timeout))    (declare (ignore buffering timeout))
104    (ccl:accept-connection socket :wait t    (let ((stream-args (and external-format
105                           :stream-args (and external-format                            `(:external-format ,external-format))))
106                                             `(:external-format ,external-format))))      (ccl:accept-connection socket :wait t :stream-args stream-args)))
107    
108  (defvar *external-format-to-coding-system*  (defvar *external-format-to-coding-system*
109    '((:iso-8859-1    '((:iso-8859-1
# Line 163  Line 117 
117    
118  ;;; Unix signals  ;;; Unix signals
119    
 (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)))  
   
120  (defimplementation getpid ()  (defimplementation getpid ()
121    (ccl::getpid))    (ccl::getpid))
122    
# Line 226  Line 174 
174        (funcall function))))        (funcall function))))
175    
176  (defimplementation swank-compile-file (input-file output-file  (defimplementation swank-compile-file (input-file output-file
177                                         load-p external-format)                                         load-p external-format
178                                           &key policy)
179      (declare (ignore policy))
180    (with-compilation-hooks ()    (with-compilation-hooks ()
181      (compile-file input-file      (compile-file input-file
182                    :output-file output-file                    :output-file output-file
183                    :load load-p                    :load load-p
184                    :external-format external-format)))                    :external-format external-format)))
185    
186  ;; 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
187  ;; as compile-time.  ;; eval-when's as compile-time.
188  (defimplementation swank-compile-string (string &key buffer position filename  (defimplementation swank-compile-string (string &key buffer position filename
189                                           policy)                                           policy)
190    (declare (ignore policy))    (declare (ignore policy))
# Line 366  Line 316 
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 ()
   ;; This is called for an async interrupt and is running in a random thread not  
   ;; selected by the user, so don't use thread-local vars such as *emacs-connection*.  
323    (let* ((conn (funcall (swank-sym default-connection))))    (let* ((conn (funcall (swank-sym default-connection))))
324      (and conn      (and conn
325           (let ((*break-on-signals* nil))           (let ((*break-on-signals* nil))
# Line 438  Line 389 
389      (let ((lfun (ccl:frame-function p context)))      (let ((lfun (ccl:frame-function p context)))
390        (format stream "(~S" (or (ccl:function-name lfun) lfun))        (format stream "(~S" (or (ccl:function-name lfun) lfun))
391        (let* ((unavailable (cons nil nil))        (let* ((unavailable (cons nil nil))
392              (args (ccl:frame-supplied-arguments p context :unknown-marker unavailable)))               (args (ccl:frame-supplied-arguments p context
393                                                     :unknown-marker unavailable)))
394          (declare (dynamic-extent unavailable))          (declare (dynamic-extent unavailable))
395          (if (eq args unavailable)          (if (eq args unavailable)
396            (format stream " #<Unknown Arguments>")              (format stream " #<Unknown Arguments>")
397            (loop for arg in args              (dolist (arg args)
398                  do (if (eq arg unavailable)                (if (eq arg unavailable)
399                       (format stream " #<Unavailable>")                    (format stream " #<Unavailable>")
400                       (format stream " ~s" arg)))))                    (format stream " ~s" arg)))))
401        (format stream ")"))))        (format stream ")"))))
402    
403    (defmacro with-frame ((p context) frame-number &body body)
404      `(call/frame ,frame-number (lambda (,p ,context) . ,body)))
405    
406  (defun call/frame (frame-number if-found)  (defun call/frame (frame-number if-found)
407    (map-backtrace    (map-backtrace
408     (lambda (p context)     (lambda (p context)
409       (return-from call/frame       (return-from call/frame
410         (funcall if-found p context)))         (funcall if-found p context)))
411     frame-number))     frame-number))
412    
413  (defmacro with-frame ((p context) frame-number &body body)  (defimplementation frame-call (frame-number)
414    `(call/frame ,frame-number (lambda (,p ,context) . ,body)))    (with-frame (p context) frame-number
415        (with-output-to-string (stream)
416          (print-frame (list :frame p context) stream))))
417    
418  (defimplementation frame-var-value (frame var)  (defimplementation frame-var-value (frame var)
419    (with-frame (p context) frame    (with-frame (p context) frame
# Line 499  Line 456 
456        (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)
457        (disassemble lfun))))        (disassemble lfun))))
458    
   
459  ;; 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)
460  ;; contains some interesting details:  ;; contains some interesting details:
461  ;;  ;;
# Line 537  Line 493 
493  ;; 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)
494  ;; 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
495  ;; 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.  
496    
497  (defun function-source-location (function)  (defun function-source-location (function)
498    (source-note-to-source-location    (source-note-to-source-location
499     (ccl:function-source-note function)     (or (ccl:function-source-note function)
500           (function-name-source-note function))
501     (lambda ()     (lambda ()
502       (format nil "Function has no source note: ~A" function))       (format nil "Function has no source note: ~A" function))
503     (ccl:function-name function)))     (ccl:function-name function)))
# Line 553  Line 505 
505  (defun pc-source-location (function pc)  (defun pc-source-location (function pc)
506    (source-note-to-source-location    (source-note-to-source-location
507     (or (ccl:find-source-note-at-pc function pc)     (or (ccl:find-source-note-at-pc function pc)
508         (ccl:function-source-note function))         (ccl:function-source-note function)
509           (function-name-source-note function))
510     (lambda ()     (lambda ()
511       (format nil "No source note at PC: ~a[~d]" function pc))       (format nil "No source note at PC: ~a[~d]" function pc))
512     (ccl:function-name function)))     (ccl:function-name function)))
513    
514    (defun function-name-source-note (fun)
515      (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function)))
516        (and defs
517             (destructuring-bind ((type . name) srcloc . srclocs) (car defs)
518               (declare (ignore type name srclocs))
519               srcloc))))
520    
521  (defun source-note-to-source-location (source if-nil-thunk &optional name)  (defun source-note-to-source-location (source if-nil-thunk &optional name)
522    (labels ((filename-to-buffer (filename)    (labels ((filename-to-buffer (filename)
523               (cond ((gethash filename *temp-file-map*)               (cond ((gethash filename *temp-file-map*)
524                      (list :buffer (gethash filename *temp-file-map*)))                      (list :buffer (gethash filename *temp-file-map*)))
525                     ((probe-file filename)                     ((probe-file filename)
526                      (list :file (ccl:native-translated-namestring (truename filename))))                      (list :file (ccl:native-translated-namestring
527                                     (truename filename))))
528                     (t (error "File ~s doesn't exist" filename)))))                     (t (error "File ~s doesn't exist" filename)))))
529      (handler-case      (handler-case
530          (cond ((ccl:source-note-p source)          (cond ((ccl:source-note-p source)
# Line 573  Line 534 
534                   (make-location                   (make-location
535                    (when file-name (filename-to-buffer (pathname file-name)))                    (when file-name (filename-to-buffer (pathname file-name)))
536                    (when start-pos (list :position (1+ start-pos)))                    (when start-pos (list :position (1+ start-pos)))
537                    (when full-text (list :snippet (subseq full-text  0 (min 40 (length full-text))))))))                    (when full-text
538                        (list :snippet (subseq full-text 0
539                                               (min 40 (length full-text))))))))
540                ((and source name)                ((and source name)
541                   ;; This branch is probably never used
542                 (make-location                 (make-location
543                  (filename-to-buffer source)                  (filename-to-buffer source)
544                  (list :function-name (let ((*package* (find-package :swank-io-package))) ;; should be buffer package.                  (list :function-name (princ-to-string
545                                         (with-standard-io-syntax                                        (if (functionp name)
546                                             (princ-to-string (if (functionp name)                                            (ccl:function-name name)
547                                                                (ccl:function-name name)                                            name)))))
                                                               name)))))))  
548                (t `(:error ,(funcall if-nil-thunk))))                (t `(:error ,(funcall if-nil-thunk))))
549        (error (c) `(:error ,(princ-to-string c))))))        (error (c) `(:error ,(princ-to-string c))))))
550    
# Line 728  Line 691 
691    (queue '() :type list))    (queue '() :type list))
692    
693  (defimplementation spawn (fun &key name)  (defimplementation spawn (fun &key name)
694    (ccl:process-run-function    (ccl:process-run-function (or name "Anonymous (Swank)")
695     (or name "Anonymous (Swank)")                              fun))
    fun))  
696    
697  (defimplementation thread-id (thread)  (defimplementation thread-id (thread)
698    (ccl:process-serial-number thread))    (ccl:process-serial-number thread))
# Line 761  Line 723 
723    (ccl:all-processes))    (ccl:all-processes))
724    
725  (defimplementation kill-thread (thread)  (defimplementation kill-thread (thread)
726    (ccl:process-kill thread))    ;;(ccl:process-kill thread) ; doesn't cut it
727      (ccl::process-initial-form-exited thread :kill))
728    
729  (defimplementation thread-alive-p (thread)  (defimplementation thread-alive-p (thread)
730    (not (ccl:process-exhausted-p thread)))    (not (ccl:process-exhausted-p thread)))

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

  ViewVC Help
Powered by ViewVC 1.1.5