/[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.25 by heller, Fri Jan 6 09:02:43 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 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    
95  (defimplementation preferred-communication-style ()  (defimplementation preferred-communication-style ()
96    :spawn)    :spawn)
97    
98  (defimplementation create-socket (host port)  (defimplementation create-socket (host port &key backlog)
99    (ccl:make-socket :connect :passive :local-port port    (ccl:make-socket :connect :passive :local-port port
100                     :local-host host :reuse-address t))                     :local-host host :reuse-address t
101                       :backlog (or backlog 5)))
102    
103  (defimplementation local-port (socket)  (defimplementation local-port (socket)
104    (ccl:local-port socket))    (ccl:local-port socket))
# Line 145  Line 107 
107    (close socket))    (close socket))
108    
109  (defimplementation accept-connection (socket &key external-format  (defimplementation accept-connection (socket &key external-format
110                                               buffering timeout)                                        buffering timeout)
111    (declare (ignore buffering timeout))    (declare (ignore buffering timeout))
112    (ccl:accept-connection socket :wait t    (let ((stream-args (and external-format
113                           :stream-args (and external-format                            `(:external-format ,external-format))))
114                                             `(:external-format ,external-format))))      (ccl:accept-connection socket :wait t :stream-args stream-args)))
115    
116  (defvar *external-format-to-coding-system*  (defvar *external-format-to-coding-system*
117    '((:iso-8859-1    '((:iso-8859-1
# Line 161  Line 123 
123    (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))    (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
124                    *external-format-to-coding-system*)))                    *external-format-to-coding-system*)))
125    
126  ;;; Unix signals  (defimplementation socket-fd (stream)
127      (ccl::ioblock-device (ccl::stream-ioblock stream t)))
128    
129  (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)))  
130    
131  (defimplementation getpid ()  (defimplementation getpid ()
132    (ccl::getpid))    (ccl::getpid))
# Line 226  Line 185 
185        (funcall function))))        (funcall function))))
186    
187  (defimplementation swank-compile-file (input-file output-file  (defimplementation swank-compile-file (input-file output-file
188                                         load-p external-format)                                         load-p external-format
189                                           &key policy)
190      (declare (ignore policy))
191    (with-compilation-hooks ()    (with-compilation-hooks ()
192      (compile-file input-file      (compile-file input-file
193                    :output-file output-file                    :output-file output-file
194                    :load load-p                    :load load-p
195                    :external-format external-format)))                    :external-format external-format)))
196    
197  ;; 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
198  ;; as compile-time.  ;; eval-when's as compile-time.
199  (defimplementation swank-compile-string (string &key buffer position filename  (defimplementation swank-compile-string (string &key buffer position filename
200                                           policy)                                           policy)
201    (declare (ignore policy))    (declare (ignore policy))
# Line 350  Line 311 
311    
312  ;;; Debugging  ;;; Debugging
313    
 (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))  
   
314  (defimplementation call-with-debugging-environment (debugger-loop-fn)  (defimplementation call-with-debugging-environment (debugger-loop-fn)
315    (let* (;;(*debugger-hook* nil)    (let* (;;(*debugger-hook* nil)
316           ;; don't let error while printing error take us down           ;; don't let error while printing error take us down
317           (ccl:*signal-printing-errors* nil))           (ccl:*signal-printing-errors* nil))
318      (funcall debugger-loop-fn)))      (funcall debugger-loop-fn)))
319    
320    ;; This is called for an async interrupt and is running in a random
321    ;; thread not selected by the user, so don't use thread-local vars
322    ;; such as *emacs-connection*.
323  (defun find-repl-thread ()  (defun find-repl-thread ()
324    ;; This is called for an async interrupt and is running in a random thread not    (let* ((*break-on-signals* nil)
325    ;; 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))))  
326      (and conn      (and conn
327           (let ((*break-on-signals* nil))           (ignore-errors ;; this errors if no repl-thread
328             (ignore-errors ;; this errors if no repl-thread             (funcall (swank-sym repl-thread) conn)))))
329               (funcall (swank-sym repl-thread) conn))))))  
   
330  (defimplementation call-with-debugger-hook (hook fun)  (defimplementation call-with-debugger-hook (hook fun)
331    (let ((*debugger-hook* hook)    (let ((*debugger-hook* hook)
332          (ccl:*break-hook* hook)          (ccl:*break-hook* hook)
# Line 396  Line 348 
348      (ccl:map-call-frames function      (ccl:map-call-frames function
349                           :origin ccl:*top-error-frame*                           :origin ccl:*top-error-frame*
350                           :start-frame-number start-frame-number                           :start-frame-number start-frame-number
351                           :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))))  
   
352    
353  (defimplementation compute-backtrace (start-frame-number end-frame-number)  (defimplementation compute-backtrace (start-frame-number end-frame-number)
354    (let (result)    (let (result)
# Line 438  Line 363 
363      (let ((lfun (ccl:frame-function p context)))      (let ((lfun (ccl:frame-function p context)))
364        (format stream "(~S" (or (ccl:function-name lfun) lfun))        (format stream "(~S" (or (ccl:function-name lfun) lfun))
365        (let* ((unavailable (cons nil nil))        (let* ((unavailable (cons nil nil))
366              (args (ccl:frame-supplied-arguments p context :unknown-marker unavailable)))               (args (ccl:frame-supplied-arguments p context
367                                                     :unknown-marker unavailable)))
368          (declare (dynamic-extent unavailable))          (declare (dynamic-extent unavailable))
369          (if (eq args unavailable)          (if (eq args unavailable)
370            (format stream " #<Unknown Arguments>")              (format stream " #<Unknown Arguments>")
371            (loop for arg in args              (dolist (arg args)
372                  do (if (eq arg unavailable)                (if (eq arg unavailable)
373                       (format stream " #<Unavailable>")                    (format stream " #<Unavailable>")
374                       (format stream " ~s" arg)))))                    (format stream " ~s" arg)))))
375        (format stream ")"))))        (format stream ")"))))
376    
377    (defmacro with-frame ((p context) frame-number &body body)
378      `(call/frame ,frame-number (lambda (,p ,context) . ,body)))
379    
380  (defun call/frame (frame-number if-found)  (defun call/frame (frame-number if-found)
381    (map-backtrace    (map-backtrace
382     (lambda (p context)     (lambda (p context)
383       (return-from call/frame       (return-from call/frame
384         (funcall if-found p context)))         (funcall if-found p context)))
385     frame-number))     frame-number))
386    
387  (defmacro with-frame ((p context) frame-number &body body)  (defimplementation frame-call (frame-number)
388    `(call/frame ,frame-number (lambda (,p ,context) . ,body)))    (with-frame (p context) frame-number
389        (with-output-to-string (stream)
390          (print-frame (list :frame p context) stream))))
391    
392  (defimplementation frame-var-value (frame var)  (defimplementation frame-var-value (frame var)
393    (with-frame (p context) frame    (with-frame (p context) frame
# Line 499  Line 430 
430        (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)
431        (disassemble lfun))))        (disassemble lfun))))
432    
   
433  ;; 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)
434  ;; contains some interesting details:  ;; contains some interesting details:
435  ;;  ;;
# Line 537  Line 467 
467  ;; 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)
468  ;; 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
469  ;; 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.  
470    
471  (defun function-source-location (function)  (defun function-source-location (function)
472    (source-note-to-source-location    (source-note-to-source-location
473     (ccl:function-source-note function)     (or (ccl:function-source-note function)
474           (function-name-source-note function))
475     (lambda ()     (lambda ()
476       (format nil "Function has no source note: ~A" function))       (format nil "Function has no source note: ~A" function))
477     (ccl:function-name function)))     (ccl:function-name function)))
# Line 553  Line 479 
479  (defun pc-source-location (function pc)  (defun pc-source-location (function pc)
480    (source-note-to-source-location    (source-note-to-source-location
481     (or (ccl:find-source-note-at-pc function pc)     (or (ccl:find-source-note-at-pc function pc)
482         (ccl:function-source-note function))         (ccl:function-source-note function)
483           (function-name-source-note function))
484     (lambda ()     (lambda ()
485       (format nil "No source note at PC: ~a[~d]" function pc))       (format nil "No source note at PC: ~a[~d]" function pc))
486     (ccl:function-name function)))     (ccl:function-name function)))
487    
488    (defun function-name-source-note (fun)
489      (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function)))
490        (and defs
491             (destructuring-bind ((type . name) srcloc . srclocs) (car defs)
492               (declare (ignore type name srclocs))
493               srcloc))))
494    
495  (defun source-note-to-source-location (source if-nil-thunk &optional name)  (defun source-note-to-source-location (source if-nil-thunk &optional name)
496    (labels ((filename-to-buffer (filename)    (labels ((filename-to-buffer (filename)
497               (cond ((gethash filename *temp-file-map*)               (cond ((gethash filename *temp-file-map*)
498                      (list :buffer (gethash filename *temp-file-map*)))                      (list :buffer (gethash filename *temp-file-map*)))
499                     ((probe-file filename)                     ((probe-file filename)
500                      (list :file (ccl:native-translated-namestring (truename filename))))                      (list :file (ccl:native-translated-namestring
501                                     (truename filename))))
502                     (t (error "File ~s doesn't exist" filename)))))                     (t (error "File ~s doesn't exist" filename)))))
503      (handler-case      (handler-case
504          (cond ((ccl:source-note-p source)          (cond ((ccl:source-note-p source)
# Line 573  Line 508 
508                   (make-location                   (make-location
509                    (when file-name (filename-to-buffer (pathname file-name)))                    (when file-name (filename-to-buffer (pathname file-name)))
510                    (when start-pos (list :position (1+ start-pos)))                    (when start-pos (list :position (1+ start-pos)))
511                    (when full-text (list :snippet (subseq full-text  0 (min 40 (length full-text))))))))                    (when full-text
512                        (list :snippet (subseq full-text 0
513                                               (min 40 (length full-text))))))))
514                ((and source name)                ((and source name)
515                   ;; This branch is probably never used
516                 (make-location                 (make-location
517                  (filename-to-buffer source)                  (filename-to-buffer source)
518                  (list :function-name (let ((*package* (find-package :swank-io-package))) ;; should be buffer package.                  (list :function-name (princ-to-string
519                                         (with-standard-io-syntax                                        (if (functionp name)
520                                             (princ-to-string (if (functionp name)                                            (ccl:function-name name)
521                                                                (ccl:function-name name)                                            name)))))
                                                               name)))))))  
522                (t `(:error ,(funcall if-nil-thunk))))                (t `(:error ,(funcall if-nil-thunk))))
523        (error (c) `(:error ,(princ-to-string c))))))        (error (c) `(:error ,(princ-to-string c))))))
524    
# Line 702  Line 639 
639                                   "Underlying UVECTOR"))))                                   "Underlying UVECTOR"))))
640                (t value)))))                (t value)))))
641    
642    (defmethod emacs-inspect ((f function))
643      (append
644       (label-value-line "Name" (function-name f))
645       `("Its argument list is: "
646         ,(princ-to-string (arglist f)) (:newline))
647       (label-value-line "Documentation" (documentation  f t))
648       (when (function-lambda-expression f)
649         (label-value-line "Lambda Expression"
650                           (function-lambda-expression f)))
651       (when (ccl:function-source-note f)
652         (label-value-line "Source note"
653                           (ccl:function-source-note f)))
654       (when (typep f 'ccl:compiled-lexical-closure)
655         (append
656          (label-value-line "Inner function" (ccl::closure-function f))
657          '("Closed over values:" (:newline))
658          (loop for (name value) in (ccl::closure-closed-over-values f)
659                append (label-value-line (format nil " ~a" name)
660                                         value))))))
661    
662  (defclass uvector-inspector ()  (defclass uvector-inspector ()
663    ((object :initarg :object)))    ((object :initarg :object)))
664    
# Line 728  Line 685 
685    (queue '() :type list))    (queue '() :type list))
686    
687  (defimplementation spawn (fun &key name)  (defimplementation spawn (fun &key name)
688    (ccl:process-run-function    (ccl:process-run-function (or name "Anonymous (Swank)")
689     (or name "Anonymous (Swank)")                              fun))
    fun))  
690    
691  (defimplementation thread-id (thread)  (defimplementation thread-id (thread)
692    (ccl:process-serial-number thread))    (ccl:process-serial-number thread))
# Line 761  Line 717 
717    (ccl:all-processes))    (ccl:all-processes))
718    
719  (defimplementation kill-thread (thread)  (defimplementation kill-thread (thread)
720    (ccl:process-kill thread))    ;;(ccl:process-kill thread) ; doesn't cut it
721      (ccl::process-initial-form-exited thread :kill))
722    
723  (defimplementation thread-alive-p (thread)  (defimplementation thread-alive-p (thread)
724    (not (ccl:process-exhausted-p thread)))    (not (ccl:process-exhausted-p thread)))
# Line 803  Line 760 
760       (when (eq timeout t) (return (values nil t)))       (when (eq timeout t) (return (values nil t)))
761       (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))       (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))
762    
763    (let ((alist '())
764          (lock (ccl:make-lock "register-thread")))
765    
766      (defimplementation register-thread (name thread)
767        (declare (type symbol name))
768        (ccl:with-lock-grabbed (lock)
769          (etypecase thread
770            (null
771             (setf alist (delete name alist :key #'car)))
772            (ccl:process
773             (let ((probe (assoc name alist)))
774               (cond (probe (setf (cdr probe) thread))
775                     (t (setf alist (acons name thread alist))))))))
776        nil)
777    
778      (defimplementation find-registered (name)
779        (ccl:with-lock-grabbed (lock)
780          (cdr (assoc name alist)))))
781    
782  (defimplementation set-default-initial-binding (var form)  (defimplementation set-default-initial-binding (var form)
783    (eval `(ccl::def-standard-initial-binding ,var ,form)))    (eval `(ccl::def-standard-initial-binding ,var ,form)))
784    

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

  ViewVC Help
Powered by ViewVC 1.1.5