Skip to content
Browse files

Merge commit '47dec9fcf9d5b8d0fb51309f3be6d29e1cd2ecb0' into develop

  • Loading branch information...
2 parents 7ca06b6 + 47dec9f commit b5b918d74389333bbf23920afe9df8f546cb32ee @hugoduncan hugoduncan committed
View
138 slime/ChangeLog
@@ -1,141 +1,3 @@
-2011-04-16 Stas Boukarev <stassats@gmail.com>
-
- * slime.el (slime-load-failed-fasl): New variable. Accepts `ask',
- `always', and `never' symbols. Loads or not loads fasls produced by
- compile-file which returned non-nil failure-p.
-
-2011-04-14 Stas Boukarev <stassats@gmail.com>
-
- * swank.lisp (list-threads): Call `use-threads-p' only when
- *emacs-connection* is non-nil. `use-threads-p' wouldn't work in
- this case, and there is no need to remove a worker thread from the
- list if it's not connected.
- This fixes an issue with calling swank:stop-server when slime
- isn't connected.
-
-2011-03-13 Stas Boukarev <stassats@gmail.com>
-
- * swank.lisp (format-restarts-for-emacs): Add
- without-printing-errors around restart printing.
-
-2011-03-09 Helmut Eller <heller@common-lisp.net>
-
- Remove slime-sexp-at-point-for-macroexpansion.
-
- * slime.el (slime-sexp-at-point-for-macroexpansion): Deleted.
- (slime-eval-macroexpand): Use slime-sexp-at-point instead.
- (slime-eval-macroexpand-inplace): Use
- slime-bounds-of-sexp-at-point directly.
-
-2011-03-09 Helmut Eller <heller@common-lisp.net>
-
- Move some of the logic from slime-sexp-at-point-for-macroexpansion
- into slime-sexp-at-point.
-
- * slime.el (slime-bounds-of-sexp-at-point): New. Special case if
- we are at '( as slime-sexp-at-point-for-macroexpansion does.
- (slime-bounds-of-symbol-at-point): New.
- (slime-symbol-at-point, slime-sexp-at-point): Use the above.
-
-2011-02-24 Stas Boukarev <stassats@gmail.com>
-
- * swank-allegro.lisp (find-topframe): Fix excl::int-newest-frame
- invocation for the latest alpha version of Allegro.
- Patch by G�bor Melis.
-
-2011-02-18 Stas Boukarev <stassats@gmail.com>
-
- * slime.el (slime-init-popup-buffer): Don't use
- multiple-value-setq on a list, XEmacs doesn't like it.
-
-2011-02-18 Stas Boukarev <stassats@gmail.com>
-
- * slime.el (slime-insert-threads): Make sure newlines have the
- same thread-id property as the rest of the line. This fixes
- confusion when point is at the end of a line.
-
-2011-02-13 Stas Boukarev <stassats@gmail.com>
-
- * slime.el (slime-inspector-operate-on-point): Don't save the
- point when inspecting a different object.
- (slime-inspector-operate-on-point): If there is no action property
- directly at the point, try looking at (1- (point)), many
- inspectable objects are presented the end of the line, so it's
- easier to navigate to them by C-e and still being able to activate
- it.
-
-2011-02-08 Stas Boukarev <stassats@gmail.com>
-
- * slime.el (slime-choose-overlay-region): Don't use `list' instead
- of `values', GNU Emacs fakes multiple values with lists, but
- XEmacs uses real multiple values.
- Reported by Raymond Toy.
-
-2011-02-04 Helmut Eller <heller@common-lisp.net>
-
- Be careful with interning.
-
- * swank.lisp (find-definitions-for-emacs): Use parse-symbol.
-
-2011-02-04 Helmut Eller <heller@common-lisp.net>
-
- Don't double encode results for eval-in-emacs.
-
- * slime.el (slime-check-eval-in-emacs-result): New.
- (slime-eval-for-lisp): Use it.
- * swank.lisp (unreadable-object): Removed.
-
-2011-02-02 Stas Boukarev <stassats@gmail.com>
-
- * swank.lisp (eval-in-emacs): Return unreadable results from Emacs
- as an unreadable-object, not as a string.
-
-2011-02-02 Stas Boukarev <stassats@gmail.com>
-
- * slime.el (slime-eval-for-lisp): Return value as a string,
- because it can be unreadable, e.g. #<buffer foo>
- * swank.lisp (eval-in-emacs): Prevent reader errors.
-
-2011-02-02 Stas Boukarev <stassats@gmail.com>
-
- * swank.lisp (eval-in-emacs): Export it.
-
-2011-01-28 Stas Boukarev <stassats@gmail.com>
-
- * slime.el (slime-check-location-filename-sanity): Guard
- against target-filename being NIL.
-
-2011-01-26 Helmut Eller <heller@common-lisp.net>
-
- Allow tail-merging in call-with-bindings.
-
- * swank.lisp (call-with-bindings): Don't use progv if alist is
- empty alist is empty.
-
-2011-01-20 Stas Boukarev <stassats@gmail.com>
-
- * swank-ecl.lisp (+TAGS+): change
- (translate-logical-pathname #P"SYS:TAGS") to
- (merge-pathnames "TAGS" (translate-logical-pathname "SYS:"))
- because of case conversion the former results in a pathname with a
- name "tags", which doesn't exist.
-
-2010-12-10 Stas Boukarev <stassats@gmail.com>
-
- * slime.el (slime-with-popup-buffer): Correct the docstring.
-
-2010-12-09 Helmut Eller <heller@common-lisp.net>
-
- * slime.el (slime-toggle-break-on-signals): New command.
- * swank.lisp (toggle-break-on-signals): The corresponding Lisp code.
-
-2010-12-02 Martin Simmons <martin@lispworks.com>
-
- * swank-lispworks.lisp (frame-actual-args): Reimplement to include
- only the values like on other platforms and deal with, optional
- key and rest args.
- (print-frame): Format the frame as a call like in other backends.
-
2010-11-13 Helmut Eller <heller@common-lisp.net>
Improve source locations for compiler messages in Lispworks.
View
61 slime/contrib/ChangeLog
@@ -1,64 +1,3 @@
-2011-03-14 Stas Boukarev <stassats@gmail.com>
-
- * swank-sprof.lisp (swank-sprof-get-call-graph): Don't call
- serialize-call-graph when there's no samples. That prevents it
- from crashing.
-
-2011-03-13 Stas Boukarev <stassats@gmail.com>
-
- * slime-sprof.el(abbreviate-name): Rename to
- slime-sprof-abbreviate-name (no package system, oh well...).
-
-2011-03-09 Helmut Eller <heller@common-lisp.net>
-
- * slime-editing-commands.el (slime-beginning-of-defun): Call
- beginning-of-defun with call-interactively so that the mark gets
- pushed.
-
-2011-01-22 Stas Boukarev <stassats@gmail.com>
-
- * slime-repl.el (slime-repl-shortcut-help): Don't make ? an alias
- for help, ? is bound to minibuffer-completion-help, and you can't
- enter it.
-
-2011-01-20 Helmut Eller <heller@common-lisp.net>
-
- * swank-mit-scheme.scm (swank:load-file): Print the result
- instead of returning it which breaks the protocol.
-
- * swank-mit-scheme.scm: Require release 9.
-
-2011-01-12 Helmut Eller <heller@common-lisp.net>
-
- Some more MIT Scheme fixes.
-
- * swank-mit-scheme.scm (swank:compile-string-for-emacs)
- (swank:compile-file-for-emacs): Use new result format.
- (swank:disassemble-form): Added with the needed kludgery for
- quoted forms.
- (swank:swank-require): Define this as nop.
-
-2011-01-11 Helmut Eller <heller@common-lisp.net>
-
- Some upgrades for MIT Scheme backend.
-
- * swank-mit-scheme.scm (netcat, netcat-accept): Use netcat-openbsd
- syntax. This version doesn't print the port number anymore
- defeating the original purpose of using netcat.
- (start-swank): Hardcode portnumber to 4055 until somebody cares
- enough to write proper server ports.
- (emacs-rex): Include a nonsense message with the :abort reply.
-
-2010-12-10 Stas Boukarev <stassats@gmail.com>
-
- * slime-sprof.el (slime-sprof-browser): Rename to
- `slime-sprof-report', leave `slime-sprof-browser' as an alias.
-
-2010-12-09 Stas Boukarev <stassats@gmail.com>
-
- * swank-fancy-inspector.lisp (emacs-inspect): Work on methods
- without associated generic function.
-
2010-10-28 Stas Boukarev <stassats@gmail.com>
* swank-package-fu.lisp (list-structure-symbols): Include the name
View
3 slime/contrib/slime-editing-commands.el
@@ -17,8 +17,7 @@
(if (and (boundp 'slime-repl-input-start-mark)
slime-repl-input-start-mark)
(slime-repl-beginning-of-defun)
- (let ((this-command 'beginning-of-defun)) ; needed for push-mark
- (call-interactively 'beginning-of-defun))))
+ (beginning-of-defun)))
(defun slime-end-of-defun ()
(interactive)
View
3 slime/contrib/slime-repl.el
@@ -1287,7 +1287,8 @@ expansion will be added to the REPL's history.)"
(not (null buffer-file-name)))))
(save-some-buffers)))
-(defslime-repl-shortcut slime-repl-shortcut-help ("help")
+
+(defslime-repl-shortcut slime-repl-shortcut-help ("help" "?")
(:handler 'slime-list-repl-short-cuts)
(:one-liner "Display the help."))
View
12 slime/contrib/slime-sprof.el
@@ -12,7 +12,7 @@
`("--"
[ "Start sb-sprof" slime-sprof-start ,C ]
[ "Stop sb-sprof" slime-sprof-stop ,C ]
- [ "Report sb-sprof" slime-sprof-report ,C ])))))
+ [ "Report sb-sprof" slime-sprof-browser ,C ])))))
(defvar slime-sprof-exclude-swank nil
"*Display swank functions in the report.")
@@ -74,9 +74,7 @@
:exclude-swank ,exclude-swank)
'slime-sprof-format))
-(defalias 'slime-sprof-browser 'slime-sprof-report)
-
-(defun slime-sprof-report ()
+(defun slime-sprof-browser ()
(interactive)
(slime-with-popup-buffer ((slime-buffer-name :sprof)
:connection t
@@ -99,7 +97,7 @@
(slime-insert-propertized
(slime-sprof-browser-name-properties)
(format (format "%%-%ds " name-length)
- (slime-sprof-abbreviate-name name name-length)))
+ (abbreviate-name name name-length)))
(insert (format "%6.2f " self))
(when cumul
(insert (format "%6.2f " cumul))
@@ -110,7 +108,7 @@
`(profile-index ,index expanded nil)))
(insert "\n")))
-(defun slime-sprof-abbreviate-name (name max-length)
+(defun abbreviate-name (name max-length)
(lexical-let ((length (min (length name) max-length)))
(subseq name 0 length)))
@@ -166,7 +164,7 @@
(slime-sprof-browser-name-properties)
(let ((len (- 59 (* 2 nesting))))
(format (format "%%-%ds " len)
- (slime-sprof-abbreviate-name name len))))
+ (abbreviate-name name len))))
(slime-sprof-browser-add-line-text-properties
`(profile-sub-index ,index))
(insert (format "%6.2f" cumul)))))))
View
34 slime/contrib/swank-fancy-inspector.lisp
@@ -412,25 +412,23 @@ See `methods-by-applicability'.")
(all-slots-for-inspector gf))))
(defmethod emacs-inspect ((method standard-method))
- `(,@(if (swank-mop:method-generic-function method)
`("Method defined on the generic function "
- (:value ,(swank-mop:method-generic-function method)
- ,(inspector-princ
- (swank-mop:generic-function-name
- (swank-mop:method-generic-function method)))))
- '("Method without a generic function"))
- (:newline)
- ,@(docstring-ispec "Documentation" method t)
- "Lambda List: " (:value ,(swank-mop:method-lambda-list method))
- (:newline)
- "Specializers: " (:value ,(swank-mop:method-specializers method)
- ,(inspector-princ (method-specializers-for-inspect method)))
- (:newline)
- "Qualifiers: " (:value ,(swank-mop:method-qualifiers method))
- (:newline)
- "Method function: " (:value ,(swank-mop:method-function method))
- (:newline)
- ,@(all-slots-for-inspector method)))
+ (:value ,(swank-mop:method-generic-function method)
+ ,(inspector-princ
+ (swank-mop:generic-function-name
+ (swank-mop:method-generic-function method))))
+ (:newline)
+ ,@(docstring-ispec "Documentation" method t)
+ "Lambda List: " (:value ,(swank-mop:method-lambda-list method))
+ (:newline)
+ "Specializers: " (:value ,(swank-mop:method-specializers method)
+ ,(inspector-princ (method-specializers-for-inspect method)))
+ (:newline)
+ "Qualifiers: " (:value ,(swank-mop:method-qualifiers method))
+ (:newline)
+ "Method function: " (:value ,(swank-mop:method-function method))
+ (:newline)
+ ,@(all-slots-for-inspector method)))
(defmethod emacs-inspect ((class standard-class))
`("Name: " (:value ,(class-name class))
View
111 slime/contrib/swank-mit-scheme.scm
@@ -8,12 +8,12 @@
;;;; Installation:
#|
-1. You need MIT Scheme 9.0.1
+1. You need MIT Scheme (version 7.7.0 and 7.7.90 seem to work).
-2. You also need the `netcat' program to create sockets
- (netcat-openbsd on Debian). MIT Scheme has some socket functions
- built-in, but I couldn't figure out how to access the locat port
- number of a server socket. We shell out to netcat to get us started.
+2. You also need the `netcat' program to create sockets. MIT Scheme
+ has some socket functions built-in, but I couldn't figure out how
+ to access the locat port number of a server socket. We shell out
+ to netcat to get us started.
3. The Emacs side needs some fiddling. I have the following in
my .emacs:
@@ -48,7 +48,6 @@
(match-string-no-properties 1)))))
(setq slime-find-buffer-package-function 'find-mit-scheme-package)
-(add-hook 'scheme-mode-hook (lambda () (slime-mode 1)))
The `mit-scheme-init' function first loads the SOS and FORMAT
libraries, then creates a package "(swank)", and loads this file
@@ -66,35 +65,14 @@
;;; package: (swank)
-(if (< (car (get-subsystem-version "Release"))
- '9)
- (error "This file requires MIT Scheme Release 9"))
-
(define (swank port)
(accept-connections (or port 4005) #f))
-;; ### hardcoded port number for now. netcat-openbsd doesn't print
-;; the listener port anymore.
(define (start-swank port-file)
- (accept-connections 4055 port-file)
- )
+ (accept-connections #f port-file))
;;;; Networking
-#|
-;; ### doesn't work because 1) open-tcp-server-socket doesn't set the
-;; SO_REUSEADDR option and 2) we can't read the port number of the
-;; created socket.
-(define (accept-connections port port-file)
- (let ((sock (open-tcp-server-socket port (host-address-loopback))))
- (format #t "Listening on port: ~s~%" port)
- (if port-file (write-port-file port port-file))
- (dynamic-wind
- (lambda () #f)
- (lambda () (serve (tcp-server-connection-accept sock #t #f)))
- (lambda () (close-tcp-server-socket sock)))))
-|#
-
(define (accept-connections port port-file)
(let ((nc (netcat port)))
(format #t "Listening on port: ~s~%" (cadr nc))
@@ -106,14 +84,22 @@
(define (netcat port)
(let* ((sh (os/shell-file-name))
- (cmd (format #f "exec netcat -v -q 0 -l ~a 2>&1" port))
+ (cmd (format #f "exec netcat -s localhost -q 0 -l -v ~a 2>&1"
+ (if port (format #f "-p ~a" port) "")))
(netcat (start-pipe-subprocess sh
(vector sh "-c" cmd)
- scheme-subprocess-environment)))
- (list netcat port)))
+ scheme-subprocess-environment))
+ (line (read-line (subprocess-input-port netcat)))
+ (match (re-string-match "^listening on \\[[^]]+\\] \\([0-9]+\\) ...$"
+ line)))
+ (cond ((not match)
+ (close-port (subprocess-input-port netcat))
+ (error "netcat:" line))
+ (else (list netcat
+ (string->number (re-match-extract line match 1)))))))
(define (netcat-accept nc)
- (let* ((rx "^Connection from .+ port .+ accepted$")
+ (let* ((rx "^connect to \\[[^]]+\\] from [^ ]+ \\[[^]]+\\] \\([0-9]+\\)$")
(line (read-line (subprocess-input-port nc)))
(match (re-string-match rx line)))
(cond ((not match) (error "netcat:" line))
@@ -231,13 +217,13 @@
(else (nearest-repl/environment))))
(define (emacs-rex socket level sexp package thread id)
- (let ((ok? #f) (result #f) (condition #f))
+ (let ((ok? #f) (result #f))
(dynamic-wind
(lambda () #f)
(lambda ()
(bind-condition-handler
(list condition-type:serious-condition)
- (lambda (c) (set! condition c) (invoke-sldb socket (1+ level) c))
+ (lambda (c) (invoke-sldb socket (1+ level) c))
(lambda ()
(fluid-let ((*buffer-package* package))
(set! result
@@ -245,14 +231,8 @@
swank-env))
(set! ok? #t)))))
(lambda ()
- (write-packet `(:return
- ,(if ok? `(:ok ,result)
- `(:abort
- ,(if condition
- (format #f "~a"
- (condition/type condition))
- "<unknown reason>")))
- ,id)
+ (write-packet `(:return ,(if ok? `(:ok ,result) '(:abort))
+ ,id)
socket)))))
(define (swank:connection-info _)
@@ -345,16 +325,13 @@
;;;; Compilation
(define (swank:compile-string-for-emacs _ string . x)
- (apply
- (lambda (errors seconds)
- `(:compilation-result ,errors t ,seconds nil nil))
- (call-compiler
- (lambda ()
- (let* ((sexps (snarf-string string))
- (env (user-env *buffer-package*))
- (scode (syntax `(begin ,@sexps) env))
- (compiled-expression (compile-scode scode #t)))
- (scode-eval compiled-expression env))))))
+ (call-compiler
+ (lambda ()
+ (let* ((sexps (snarf-string string))
+ (env (user-env *buffer-package*))
+ (scode (syntax `(begin ,@sexps) env))
+ (compiled-expression (compile-scode scode #t)))
+ (scode-eval compiled-expression env)))))
(define (snarf-string string)
(with-input-from-string string
@@ -368,33 +345,22 @@
(with-timings fun
(lambda (run-time gc-time real-time)
(set! time real-time)))
- (list 'nil (internal-time/ticks->seconds time))))
+ (list 'nil (format #f "~a" (internal-time/ticks->seconds time)))))
(define (swank:compiler-notes-for-emacs _) nil)
(define (swank:compile-file-for-emacs socket file load?)
- (apply
- (lambda (errors seconds)
- (list ':compilation-result errors 't seconds load?
- (->namestring (pathname-new-type file "com"))))
- (call-compiler
- (lambda () (with-output-to-repl socket (lambda () (compile-file file)))))))
+ (call-compiler
+ (lambda ()
+ (with-output-to-repl socket
+ (lambda () (compile-file file)))
+ (cond ((elisp-true? load?)
+ (load (pathname-new-type file "com")
+ (user-env *buffer-package*)))))))
(define (swank:load-file socket file)
(with-output-to-repl socket
- (lambda ()
- (pprint-to-string
- (load file (user-env *buffer-package*))))))
-
-(define (swank:disassemble-form _ string)
- (let ((sexp (let ((sexp (read-from-string string)))
- (cond ((and (pair? sexp) (eq? (car sexp) 'quote))
- (cadr sexp))
- (#t sexp)))))
- (with-output-to-string
- (lambda ()
- (compiler:disassemble
- (eval sexp (user-env *buffer-package*)))))))
+ (lambda () (load file (user-env *buffer-package*)))))
(define (swank:disassemble-symbol _ string)
(with-output-to-string
@@ -437,7 +403,6 @@
;;; Some unimplemented stuff.
(define (swank:buffer-first-change . _) nil)
(define (swank:filename-to-modulename . _) nil)
-(define (swank:swank-require . _) nil)
;; M-. is beyond my capabilities.
(define (swank:find-definitions-for-emacs . _) nil)
View
4 slime/contrib/swank-sprof.lisp
@@ -74,8 +74,8 @@
`((nil "Elsewhere" ,rest nil nil)))))))))
(defslimefun swank-sprof-get-call-graph (&key exclude-swank)
- (when (setf *call-graph* (sb-sprof:report :type nil))
- (serialize-call-graph :exclude-swank exclude-swank)))
+ (setf *call-graph* (sb-sprof:report :type nil))
+ (serialize-call-graph :exclude-swank exclude-swank))
(defslimefun swank-sprof-expand-node (index)
(let* ((node (gethash index *number-nodes*)))
View
4 slime/doc/slime.texi
@@ -12,7 +12,7 @@
@set EDITION 3.0-alpha
@set SLIMEVER 3.0-alpha
@c @set UPDATED @today{}
-@set UPDATED @code{$Date: 2010/12/10 15:05:06 $}
+@set UPDATED @code{$Date: 2010/04/05 18:56:13 $}
@set TITLE SLIME User Manual
@settitle @value{TITLE}, version @value{EDITION}
@@ -2958,7 +2958,7 @@ Start profiling.
@cmditem{slime-sprof-stop}
Stop profiling.
-@cmditem{slime-sprof-report}
+@cmditem{slime-sprof-browser}
Report results of the profiling.
@end table
View
191 slime/slime.el
@@ -895,10 +895,10 @@ Restore window configuration when closed.
NAME is the name of the buffer to be created.
PACKAGE is the value `slime-buffer-package'.
-CONNECTION is the value for `slime-buffer-connection',
- if nil, no explicit connection is associated with
- the buffer. If t, the current connection is taken.
+CONNECTION is the value for `slime-buffer-connection'.
MODE is the name of a major mode which will be enabled.
+If nil, no explicit connection is associated with
+the buffer. If t, the current connection is taken.
"
`(let* ((vars% (list ,(if (eq package t) '(slime-current-package) package)
,(if (eq connection t) '(slime-connection) connection)))
@@ -927,8 +927,8 @@ The buffer also uses the minor-mode `slime-popup-buffer-mode'."
(defun slime-init-popup-buffer (buffer-vars)
(slime-popup-buffer-mode 1)
- (setf slime-buffer-package (car buffer-vars)
- slime-buffer-connection (cadr buffer-vars)))
+ (multiple-value-setq (slime-buffer-package slime-buffer-connection)
+ buffer-vars))
(defun slime-display-popup-buffer (select)
"Display the current buffer.
@@ -2664,33 +2664,17 @@ to it depending on its sign."
',slime-compilation-policy)
#'slime-compilation-finished)))
-(defcustom slime-load-failed-fasl 'ask
- "Which action to take when COMPILE-FILE set FAILURE-P to T.
-NEVER doesn't load the fasl
-ALWAYS loads the fasl
-ASK asks the user."
- :type '(choice (const never)
- (const always)
- (const ask)))
-
-(defun slime-load-failed-fasl-p ()
- (ecase slime-load-failed-fasl
- (never nil)
- (always t)
- (ask (y-or-n-p "Compilation failed. Load fasl file anyway? "))))
-
(defun slime-compilation-finished (result)
(with-struct (slime-compilation-result. notes duration successp
loadp faslfile) result
(setf slime-last-compilation-result result)
- (slime-show-note-counts notes duration (cond ((not loadp) successp)
- (t (and faslfile successp))))
+ (slime-show-note-counts notes duration successp)
(when slime-highlight-compiler-notes
(slime-highlight-notes notes))
(run-hook-with-args 'slime-compilation-finished-hook notes)
(when (and loadp faslfile
(or successp
- (slime-load-failed-fasl-p)))
+ (y-or-n-p "Compilation failed. Load fasl file anyway? ")))
(slime-eval-async `(swank:load-file ,faslfile)))))
(defun slime-show-note-counts (notes secs successp)
@@ -3044,7 +3028,7 @@ Return nil if there's no useful source location."
((eq (slime-note.severity note) :read-error)
(slime-choose-overlay-for-read-error location))
((equal pos '(:eof))
- (values (1- (point-max)) (point-max)))
+ (list (1- (point-max)) (point-max)))
(t
(slime-choose-overlay-for-sexp location))))))))
@@ -3237,8 +3221,7 @@ you should check twice before modifying.")
(flet ((file-truename-safe (filename) (and filename (file-truename filename))))
(let ((target-filename (file-truename-safe filename))
(buffer-filename (file-truename-safe (buffer-file-name))))
- (when (and target-filename
- buffer-filename)
+ (when buffer-filename
(slime-maybe-warn-for-different-source-root
target-filename buffer-filename))))))
@@ -4024,38 +4007,14 @@ The result is a (possibly empty) list of definitions."
(defun slime-eval-for-lisp (thread tag form-string)
(let ((ok nil)
(value nil)
- (error nil)
(c (slime-connection)))
- (unwind-protect
- (condition-case err
- (progn
- (slime-check-eval-in-emacs-enabled)
- (setq value (eval (read form-string)))
- (slime-check-eval-in-emacs-result value)
- (setq ok t))
- ((debug error)
- (setq error err)))
- (let ((result (cond (ok `(:ok ,value))
- (error `(:error ,(symbol-name (car error))
- . ,(mapcar #'prin1-to-string
- (cdr error))))
- (t `(:abort)))))
+ (unwind-protect (progn
+ (slime-check-eval-in-emacs-enabled)
+ (setq value (eval (read form-string)))
+ (setq ok t))
+ (let ((result (if ok `(:ok ,value) `(:abort))))
(slime-dispatch-event `(:emacs-return ,thread ,tag ,result) c)))))
-(defun slime-check-eval-in-emacs-result (x)
- "Raise an error if X can't be marshaled."
- (or (stringp x)
- (memq x '(nil t))
- (integerp x)
- (keywordp x)
- (and (consp x)
- (let ((l x))
- (while (consp l)
- (slime-check-eval-in-emacs-result (car x))
- (setq l (cdr l)))
- (slime-check-eval-in-emacs-result l)))
- (error "Non-serializable return value: %S" x)))
-
(defun slime-check-eval-in-emacs-enabled ()
"Raise an error if `slime-enable-evaluate-in-emacs' isn't true."
(unless slime-enable-evaluate-in-emacs
@@ -4977,12 +4936,32 @@ When displaying XREF information, this goes to the previous reference."
(slime-remove-edits (point-min) (point-max)))
(undo-only arg))))
+(defun slime-sexp-at-point-for-macroexpansion ()
+ "`slime-sexp-at-point' with special cases for LOOP."
+ (let ((string (slime-sexp-at-point-or-error))
+ (bounds (bounds-of-thing-at-point 'sexp))
+ (char-at-point (substring-no-properties (thing-at-point 'char))))
+ ;; SLIME-SEXP-AT-POINT(-OR-ERROR) uses (THING-AT-POINT 'SEXP)
+ ;; which is quite a bit botched: it returns "'(FOO BAR BAZ)" even
+ ;; when point is placed _at the opening parenthesis_, and hence
+ ;; "(FOO BAR BAZ)" wouldn't get expanded. Likewise for ",(...)",
+ ;; ",@(...)" (would return "@(...)"!!), and "\"(...)".
+ ;; So we better fix this up here:
+ (when (string= char-at-point "(")
+ (let ((char0 (elt string 0)))
+ (when (member char0 '(?\' ?\, ?\" ?\@))
+ (setf string (substring string 1))
+ (incf (car bounds)))))
+ (list string (cons (set-marker (make-marker) (car bounds))
+ (set-marker (make-marker) (cdr bounds))))))
+
(defvar slime-eval-macroexpand-expression nil
"Specifies the last macroexpansion preformed.
This variable specifies both what was expanded and how.")
(defun slime-eval-macroexpand (expander &optional string)
- (let ((string (or string (slime-sexp-at-point))))
+ (let ((string (or string
+ (car (slime-sexp-at-point-for-macroexpansion)))))
(setq slime-eval-macroexpand-expression `(,expander ,string))
(slime-eval-async slime-eval-macroexpand-expression
#'slime-initialize-macroexpansion-buffer)))
@@ -5019,15 +4998,15 @@ This variable specifies both what was expanded and how.")
NB: Does not affect slime-eval-macroexpand-expression"
(interactive)
- (let* ((bounds (or (slime-bounds-of-sexp-at-point)
- (error "No sexp at point"))))
- (lexical-let* ((start (copy-marker (car bounds)))
- (end (copy-marker (cdr bounds)))
+ (destructuring-bind (string bounds)
+ (slime-sexp-at-point-for-macroexpansion)
+ (lexical-let* ((start (car bounds))
+ (end (cdr bounds))
(point (point))
(package (slime-current-package))
(buffer (current-buffer)))
(slime-eval-async
- `(,expander ,(buffer-substring-no-properties start end))
+ `(,expander ,string)
(lambda (expansion)
(with-current-buffer buffer
(let ((buffer-read-only nil))
@@ -6085,12 +6064,6 @@ was called originally."
((:ok value) (message "%s" value))
((:abort _)))))
-(defun slime-toggle-break-on-signals ()
- "Toggle the value of *break-on-signals*."
- (interactive)
- (slime-eval-async `(swank:toggle-break-on-signals)
- (lambda (msg) (message "%s" msg))))
-
;;;;;; SLDB recompilation commands
@@ -6201,6 +6174,7 @@ was called originally."
(cons labels (cdr threads))))
(defun slime-insert-thread (thread longest-lines)
+ (unless (bolp) (insert "\n"))
(loop for i from 0
for align in longest-lines
for element in thread
@@ -6228,8 +6202,7 @@ was called originally."
for thread in (cdr threads)
do
(slime-propertize-region `(thread-id ,index)
- (slime-insert-thread thread longest-lines)
- (insert "\n")))))
+ (slime-insert-thread thread longest-lines)))))
;;;;; Major mode
@@ -6520,17 +6493,6 @@ position of point in the current buffer."
(cons (line-number-at-pos)
(current-column))))
-(defun slime-inspector-property-at-point ()
- (let ((properties '(slime-part-number slime-range-button
- slime-action-number)))
- (flet ((find-property (point)
- (loop for property in properties
- for value = (get-text-property point property)
- when value
- return (list property value))))
- (or (find-property (point))
- (find-property (1- (point)))))))
-
(defun slime-inspector-operate-on-point ()
"Invoke the command for the text at point.
1. If point is on a value then recursivly call the inspector on
@@ -6538,26 +6500,23 @@ that value.
2. If point is on an action then call that action.
3. If point is on a range-button fetch and insert the range."
(interactive)
- (let ((opener (lexical-let ((point (slime-inspector-position)))
+ (let ((part-number (get-text-property (point) 'slime-part-number))
+ (range-button (get-text-property (point) 'slime-range-button))
+ (action-number (get-text-property (point) 'slime-action-number))
+ (opener (lexical-let ((point (slime-inspector-position)))
(lambda (parts)
(when parts
- (slime-open-inspector parts point)))))
- (new-opener (lambda (parts)
- (when parts
- (slime-open-inspector parts)))))
- (destructuring-bind (property value)
- (slime-inspector-property-at-point)
- (case property
- (slime-part-number
- (slime-eval-async `(swank:inspect-nth-part ,value)
- new-opener)
+ (slime-open-inspector parts point))))))
+ (cond (part-number
+ (slime-eval-async `(swank:inspect-nth-part ,part-number)
+ opener)
(push (slime-inspector-position) slime-inspector-mark-stack))
- (slime-range-button
- (slime-inspector-fetch-more value))
- (slime-action-number
- (slime-eval-async `(swank::inspector-call-nth-action ,value)
+ (range-button
+ (slime-inspector-fetch-more range-button))
+ (action-number
+ (slime-eval-async `(swank::inspector-call-nth-action ,action-number)
opener))
- (t (error "No object at point"))))))
+ (t (error "No object at point")))))
(defun slime-inspector-operate-on-click (event)
"Move to events' position and operate the part."
@@ -7690,8 +7649,7 @@ BODY returns true if the check succeeds."
'(("foo")
("#:foo")
("#'foo")
- ("#'(lambda (x) x)")
- ("()"))
+ ("#'(lambda (x) x)"))
(with-temp-buffer
(lisp-mode)
(insert string)
@@ -8595,7 +8553,7 @@ and skips comments."
(defun slime-beginning-of-symbol ()
"Move to the beginning of the CL-style symbol at point."
- (while (re-search-backward "\\(\\sw\\|\\s_\\|\\s\\.\\|\\s\\\\|[#@|]\\)\\="
+ (while (re-search-backward "\\(\\sw\\|\\s_\\|\\s\\.\\|\\s\\\\|[#@|]\\)\\="
(when (> (point) 2000) (- (point) 2000))
t))
(re-search-forward "\\=#[-+.<|]" nil t)
@@ -8617,40 +8575,19 @@ The result is unspecified if there isn't a symbol under the point."
(defun slime-symbol-end-pos ()
(save-excursion (slime-end-of-symbol) (point)))
-(defun slime-bounds-of-symbol-at-point ()
- "Return the bounds of the symbol around point.
-The returned bounds are either nil or non-empty."
- (let ((bounds (bounds-of-thing-at-point 'slime-symbol)))
- (if (and bounds
- (< (car bounds)
- (cdr bounds)))
- bounds)))
-
(defun slime-symbol-at-point ()
"Return the name of the symbol at point, otherwise nil."
;; (thing-at-point 'symbol) returns "" in empty buffers
- (let ((bounds (slime-bounds-of-symbol-at-point)))
- (if bounds
- (buffer-substring-no-properties (car bounds)
- (cdr bounds)))))
-
-(defun slime-bounds-of-sexp-at-point ()
- "Return the bounds sexp at point as a pair (or nil)."
- (or (slime-bounds-of-symbol-at-point)
- (and (equal (char-after) ?\()
- (member (char-before) '(?\' ?\, ?\@))
- ;; hide stuff before ( to avoid quirks with '( etc.
- (save-restriction
- (narrow-to-region (point) (point-max))
- (bounds-of-thing-at-point 'sexp)))
- (bounds-of-thing-at-point 'sexp)))
+ (let ((string (thing-at-point 'slime-symbol)))
+ (and string
+ (not (equal string ""))
+ (substring-no-properties string))))
(defun slime-sexp-at-point ()
"Return the sexp at point as a string, otherwise nil."
- (let ((bounds (slime-bounds-of-sexp-at-point)))
- (if bounds
- (buffer-substring-no-properties (car bounds)
- (cdr bounds)))))
+ (or (slime-symbol-at-point)
+ (let ((string (thing-at-point 'sexp)))
+ (if string (substring-no-properties string) nil))))
(defun slime-sexp-at-point-or-error ()
"Return the sexp at point as a string, othwise signal an error."
View
2 slime/swank-allegro.lisp
@@ -149,7 +149,7 @@
(defun find-topframe ()
(let ((magic-symbol (intern (symbol-name :swank-debugger-hook)
(find-package :swank)))
- (top-frame (excl::int-newest-frame (excl::current-thread))))
+ (top-frame (excl::int-newest-frame)))
(loop for frame = top-frame then (next-frame frame)
for name = (debugger:frame-name frame)
for i from 0
View
3 slime/swank-ecl.lisp
@@ -498,8 +498,7 @@
;;;; Definitions
-(defvar +TAGS+ (namestring
- (merge-pathnames "TAGS" (translate-logical-pathname "SYS:"))))
+(defvar +TAGS+ (namestring (translate-logical-pathname #P"SYS:TAGS")))
(defun make-file-location (file file-position)
;; File positions in CL start at 0, but Emacs' buffer positions
View
41 slime/swank-lispworks.lisp
@@ -365,39 +365,20 @@ Return NIL if the symbol is unbound."
(push frame backtrace)))))
(defun frame-actual-args (frame)
- (let ((*break-on-signals* nil)
- (kind nil))
- (loop for arg in (dbg::call-frame-arglist frame)
- if (eq kind '&rest)
- nconc (handler-case
- (dbg::dbg-eval arg frame)
- (error (e) (list (format nil "<~A>" arg))))
- and do (loop-finish)
- else
- if (member arg '(&rest &optional &key))
- do (setq kind arg)
- else
- nconc
- (handler-case
- (nconc (and (eq kind '&key)
- (list (cond ((symbolp arg)
- (intern (symbol-name arg) :keyword))
- ((and (consp arg) (symbolp (car arg)))
- (intern (symbol-name (car arg)) :keyword))
- (t (caar arg)))))
- (list (dbg::dbg-eval
- (cond ((symbolp arg) arg)
- ((and (consp arg) (symbolp (car arg)))
- (car arg))
- (t (cadar arg)))
- frame)))
- (error (e) (list (format nil "<~A>" arg)))))))
+ (let ((*break-on-signals* nil))
+ (mapcar (lambda (arg)
+ (case arg
+ ((&rest &optional &key) arg)
+ (t
+ (handler-case (dbg::dbg-eval arg frame)
+ (error (e) (format nil "<~A>" arg))))))
+ (dbg::call-frame-arglist frame))))
(defimplementation print-frame (frame stream)
(cond ((dbg::call-frame-p frame)
- (prin1 (cons (dbg::call-frame-function-name frame)
- (frame-actual-args frame))
- stream))
+ (format stream "~S ~S"
+ (dbg::call-frame-function-name frame)
+ (frame-actual-args frame)))
(t (princ frame stream))))
(defun frame-vars (frame)
View
44 slime/swank.lisp
@@ -64,8 +64,7 @@
#:default-directory
#:set-default-directory
#:quit-lisp
- #:eval-for-emacs
- #:eval-in-emacs))
+ #:eval-for-emacs))
(in-package :swank)
@@ -178,13 +177,11 @@ bound to the corresponding VALUE.")
(defun call-with-bindings (alist fun)
"Call FUN with variables bound according to ALIST.
ALIST is a list of the form ((VAR . VAL) ...)."
- (if (null alist)
- (funcall fun)
- (let* ((rlist (reverse alist))
- (vars (mapcar #'car rlist))
- (vals (mapcar #'cdr rlist)))
- (progv vars vals
- (funcall fun)))))
+ (let* ((rlist (reverse alist))
+ (vars (mapcar #'car rlist))
+ (vals (mapcar #'cdr rlist)))
+ (progv vars vals
+ (funcall fun))))
(defmacro with-bindings (alist &body body)
"See `call-with-bindings'."
@@ -1819,8 +1816,7 @@ converted to lower case."
(princ-to-string form)))))
(defun eval-in-emacs (form &optional nowait)
- "Eval FORM in Emacs.
-`slime-enable-evaluate-in-emacs' should be set to T on the Emacs side."
+ "Eval FORM in Emacs."
(cond (nowait
(send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
(t
@@ -1831,7 +1827,6 @@ converted to lower case."
(let ((value (caddr (wait-for-event `(:emacs-return ,tag result)))))
(destructure-case value
((:ok value) value)
- ((:error kind . data) (error "~a: ~{~a~}" kind data))
((:abort) (abort))))))))
(defvar *swank-wire-protocol-version* nil
@@ -2035,8 +2030,7 @@ considered to represent a symbol internal to some current package.)"
(char-upcase char)))))
-(defun find-symbol-with-status (symbol-name status
- &optional (package *package*))
+(defun find-symbol-with-status (symbol-name status &optional (package *package*))
(multiple-value-bind (symbol flag) (find-symbol symbol-name package)
(if (and flag (eq flag status))
(values symbol flag)
@@ -2599,12 +2593,8 @@ format suitable for Emacs."
(loop for restart in *sldb-restarts* collect
(list (format nil "~:[~;*~]~a"
(eq restart *sldb-quit-restart*)
- (restart-name restart))
- (with-output-to-string (stream)
- (without-printing-errors (:object restart
- :stream stream
- :msg "<<error printing restart>>")
- (princ restart stream)))))))
+ (restart-name restart) )
+ (princ-to-string restart)))))
;;;;; SLDB entry points
@@ -2769,10 +2759,6 @@ TAGS has is a list of strings."
(define-stepper-function sldb-next sldb-step-next)
(define-stepper-function sldb-out sldb-step-out)
-(defslimefun toggle-break-on-signals ()
- (setq *break-on-signals* (not *break-on-signals*))
- (format nil "*break-on-signals* = ~a" *break-on-signals*))
-
;;;; Compilation Commands.
@@ -3311,10 +3297,9 @@ Include the nicknames if NICKNAMES is true."
(defslimefun find-definitions-for-emacs (name)
"Return a list ((DSPEC LOCATION) ...) of definitions for NAME.
DSPEC is a string and LOCATION a source location. NAME is a string."
- (multiple-value-bind (symbol found) (with-buffer-syntax ()
- (parse-symbol name))
- (when found
- (mapcar #'xref>elisp (find-definitions symbol)))))
+ (multiple-value-bind (sexp error) (ignore-errors (from-string name))
+ (unless error
+ (mapcar #'xref>elisp (find-definitions sexp)))))
;;; Generic function so contribs can extend it.
(defgeneric xref-doit (type thing)
@@ -3761,8 +3746,7 @@ a time.")
LABELS is a list of attribute names and the remaining lists are the
corresponding attribute values per thread."
(setq *thread-list* (all-threads))
- (when (and *emacs-connection*
- (use-threads-p)
+ (when (and (use-threads-p)
(equalp (thread-name (current-thread)) "worker"))
(setf *thread-list* (delete (current-thread) *thread-list*)))
(let* ((plist (thread-attributes (car *thread-list*)))

0 comments on commit b5b918d

Please sign in to comment.
Something went wrong with that request. Please try again.