From lgorrie at common-lisp.net Wed Oct 15 14:43:56 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 15 Oct 2003 10:43:56 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30632 Modified Files: slime.el Log Message: Set `indent-tabs-mode' to nil. This makes diffs look better. (slime-start-swank-server): Now passing the port number of SWANK:START-SERVER. (slime-evaluating-state): Debugging synchronous evaluations with recursive edits now works. (slime-forward-sexp): Added support for #|...|# reading comments. (sldb-hook): New hook for entry to the debugger (used for the test suite). (slime-run-tests): Reworked the testing framework. Now presents results in an outline-mode buffer, with only the subtrees containing failed tests expanded initially. (slime-check): Check-name can now be a string or format-control. (Test cases have been updated to take advantage of this.) (compile-defun): This test case now works for the case containing #|..|# (async-eval-debugging): New test case for recursively debugging asynchronous evaluation. Date: Wed Oct 15 10:43:56 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.30 slime/slime.el:1.31 --- slime/slime.el:1.30 Wed Oct 15 10:17:52 2003 +++ slime/slime.el Wed Oct 15 10:43:56 2003 @@ -1,4 +1,4 @@ -;; -*- mode: emacs-lisp; mode: outline-minor; outline-regexp: ";;;;*"; tab-width: 8; indent-tabs-mode: t -*- +;; -*- mode: emacs-lisp; mode: outline-minor; outline-regexp: ";;;;*"; indent-tabs-mode: nil -*- ;; slime.el -- Superior Lisp Interaction Mode, Extended ;;; License ;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller @@ -61,7 +61,7 @@ (require 'easy-mmode) (defalias 'define-minor-mode 'easy-mmode-define-minor-mode)) -(defconst slime-swank-port 4005 +(defvar slime-swank-port 4005 "TCP port number for the Lisp Swank server.") (defvar slime-path @@ -94,6 +94,10 @@ (defvar slime-pid nil "The process id of the Lisp process.") +(defvar slime-dont-prompt nil + "When true, don't prompt the user for input during startup. +This is used for batch-mode testing.") + ;;; Customize group @@ -493,7 +497,7 @@ (format "(load %S)\n" (concat slime-path slime-backend))) (comint-proc-query (inferior-lisp-proc) - "(swank:start-server)\n")) + (format "(swank:start-server %S)\n" slime-swank-port))) (defun slime-maybe-compile-swank () (let ((source (concat slime-path slime-backend ".lisp")) @@ -502,11 +506,13 @@ (inferior-lisp-proc) (format "(compile-file %S)\n" source)))) (when (or (and (not (file-exists-p binary)) - (y-or-n-p "\ -The CMUCL support library (Swank) is not compiled. Compile now? ")) + (or slime-dont-prompt + (y-or-n-p "\ +The CMUCL support library (Swank) is not compiled. Compile now? "))) (and (file-newer-than-file-p source binary) - (y-or-n-p "\ -Your Swank binary is older than the source. Recompile now? "))) + (or slime-dont-prompt + (y-or-n-p "\ +Your Swank binary is older than the source. Recompile now? ")))) (compile-swank))))) (defun slime-fetch-features-list () @@ -703,8 +709,10 @@ "Dispatch an event to the current state. Certain \"out of band\" events are handled specially instead of going into the state machine." - (or (slime-handle-oob event) - (funcall (slime-state-function (slime-current-state)) event))) + (unwind-protect + (or (slime-handle-oob event) + (funcall (slime-state-function (slime-current-state)) event)) + (slime-process-available-input))) (defun slime-handle-oob (event) "Handle out-of-band events. @@ -763,6 +771,9 @@ (defvar sldb-level 0 "Current debug level, or 0 when not debugging.") +(defvar slime-stack-eval-tags nil + "List of stack-tags of continuations waiting on the stack.") + (slime-defstate slime-idle-state () "Idle state. The only event allowed is to make a request." ((activate) @@ -777,10 +788,20 @@ will pass it to CONTINUATION." ((:ok result) (slime-pop-state) - (funcall continuation result)) + (destructure-case continuation + ((:function f) + (funcall f result)) + ((:catch-tag tag) + (when (member tag slime-stack-eval-tags) + (throw tag `(:ok ,result)))))) ((:aborted) (slime-pop-state) - (message "Evaluation aborted.")) + (destructure-case continuation + ((:function f) + (message "Evaluation aborted.")) + ((:catch-tag tag) + (when (member tag slime-stack-eval-tags) + (throw tag `(:aborted)))))) ((:debug level condition restarts stack-depth frames) (slime-push-state (slime-debugging-state level condition restarts stack-depth frames))) @@ -819,7 +840,7 @@ (defun slime-output-evaluate-request (form-string package-name) "Send a request for LISP to read and evaluate FORM-STRING in PACKAGE-NAME." (slime-net-send `(swank:eval-string ,form-string ,package-name))) - + (defun slime-check-connected () (unless (and slime-net-process (eq (process-status slime-net-process) 'open)) @@ -841,15 +862,32 @@ (defun slime-eval (sexp &optional package) "Evaluate EXPR on the superior Lisp and return the result." (slime-check-connected) - (catch 'slime-result - (let ((continuation (lambda (value) (throw 'slime-result value)))) - (slime-eval-async sexp package continuation) - (loop (accept-process-output))))) + (let* ((tag (gensym "slime-result-")) + (slime-stack-eval-tags (cons tag slime-stack-eval-tags))) + (destructure-case + (catch tag (slime-do-eval sexp package `(:catch-tag ,tag))) + ((:ok value) + value) + ((:aborted) + (error "Lisp Evaluation aborted."))))) + +(defun slime-do-eval (sexp package continuation) + "Perform an evaluation synchronously. +Loops until the result is thrown to our caller, or the user aborts." + (slime-eval-string-async (prin1-to-string sexp) package continuation) + (while (slime-busy-p) + (accept-process-output)) + ;; No longer busy, but result not delivered. That means we have + ;; entered the debugger. + (recursive-edit) + ;; If we get here, the user completed the recursive edit without + ;; coaxing the debugger into returning. We abort. + (error "Evaluation aborted.")) (defun slime-eval-async (sexp package cont) "Evaluate EXPR on the superior Lisp and call CONT with the result." (slime-check-connected) - (slime-eval-string-async (prin1-to-string sexp) package cont)) + (slime-eval-string-async (prin1-to-string sexp) package `(:function ,cont))) (defun slime-sync () "Block until any asynchronous command has completed." @@ -1092,7 +1130,6 @@ sev1 sev2)) - (defun slime-visit-source-path (source-path) "Visit a full source path including the top-level form." (ignore-errors @@ -1157,21 +1194,42 @@ (defun slime-forward-sexp (&optional count) "Like `forward-sexp', but understands reader-conditionals (#- and #+)." (dotimes (i (or count 1)) - (slime-forward-reader-conditional) + (while (slime-point-moves-p (slime-forward-blanks) + (slime-forward-reader-comment) + (slime-forward-reader-conditional))) (forward-sexp))) +(defun slime-forward-blanks () + "Move forward over all whitespace and newlines at point." + (while (slime-point-moves-p + (skip-syntax-forward " ") + ;; newlines aren't in lisp-mode's whitespace syntax class + (when (eolp) (forward-char))))) + +;; Emacs 21's forward-sexp understands #| |# comments in lisp-mode +;; buffers, but (at least) Emacs 20's doesn't, so here it is. +(defun slime-forward-reader-comment () + "Move forward over #|...|# reader comments. The comments may be nested." + (when (looking-at "#|") + (goto-char (match-end 0)) + (while (not (looking-at "|#")) + (re-search-forward (regexp-opt '("|#" "#|"))) + (goto-char (match-beginning 0)) + (when (looking-at "#|") ; nested comment + (slime-forward-reader-comment))) + (goto-char (match-end 0)))) + (defun slime-forward-reader-conditional () - "Move past any reader conditionals (#+ or #-) at point." - (while (progn (slime-beginning-of-next-sexp) - (or (looking-at "\\s *#\\+") - (looking-at "\\s *#-"))) + "Move past any reader conditional (#+ or #-) at point." + (when (or (looking-at "#\\+") + (looking-at "#-")) (goto-char (match-end 0)) (let* ((plus-conditional-p (eq (char-before) ?+)) (result (slime-eval-feature-conditional (read (current-buffer))))) (unless (if plus-conditional-p result (not result)) ;; skip this sexp - (forward-sexp))))) - + (slime-forward-sexp))))) + (defun slime-beginning-of-next-sexp () "Move the point to the first character of the next sexp." (forward-sexp) @@ -1282,11 +1340,19 @@ "Show the argument list for the nearest function call, if any." (interactive (list (slime-read-symbol "Arglist of: "))) (slime-eval-async - `(swank:arglist-string ',symbol-name) + `(swank:arglist-string ,symbol-name) (slime-buffer-package) (lexical-let ((symbol-name symbol-name)) (lambda (arglist) - (message "(%s %s)" symbol-name (substring arglist 1 -1)))))) + (message (slime-format-arglist symbol-name arglist)))))) + +(defun slime-get-arglist (symbol-name) + "Return the argument list for SYMBOL-NAME." + (slime-format-arglist symbol-name + (slime-eval `(swank:arglist-string ,symbol-name)))) + +(defun slime-format-arglist (symbol-name arglist) + (format "(%s %s)" symbol-name (substring arglist 1 -1))) ;;; Completion @@ -1878,6 +1944,9 @@ (defvar sldb-backtrace-start-marker) (defvar sldb-mode-map) +(defvar sldb-hook nil + "Hook run on entry to the debugger.") + (defun slime-debugger-hook () (slime-enter-sldb)) @@ -1910,7 +1979,8 @@ (setq sldb-backtrace-start-marker (point-marker)) (sldb-insert-frames frames) (setq buffer-read-only t) - (pop-to-buffer (current-buffer)))) + (pop-to-buffer (current-buffer)) + (run-hooks 'sldb-hook))) (defun slime-insert-propertized (props &rest args) (let ((start (point))) @@ -2257,45 +2327,130 @@ (defvar slime-test-debug-on-error nil "*When non-nil debug errors in test cases.") -(defvar slime-test-verbose-p nil - "*When non-nil do not display the results of individual checks.") - (defvar slime-total-tests nil "Total number of tests executed during a test run.") (defvar slime-failed-tests nil "Total number of failed tests during a test run.") +(defvar slime-test-buffer-name "*Tests*" + "The name of the buffer used to display test results.") + + +;;;;; Execution engine + (defun slime-run-tests () - (interactive) - (slime-with-output-to-temp-buffer "*Tests*" - (with-current-buffer standard-output - (set (make-local-variable 'truncate-lines) t)) - (slime-execute-tests))) + "Run the test suite. +The results are presented in an outline-mode buffer, with the tests +that succeeded initially folded away." + (interactive) + (slime-create-test-results-buffer) + (unwind-protect + (slime-execute-tests) + (pop-to-buffer slime-test-buffer-name) + (goto-char (point-min)) + (hide-body) + ;; Expose failed tests + (dolist (o (overlays-in (point-min) (point-max))) + (when (overlay-get o 'slime-failed-test) + (goto-char (overlay-start o)) + (show-subtree))))) (defun slime-execute-tests () + "Execute each test case with each input. +Return the number of failed tests." (save-window-excursion (let ((slime-total-tests 0) (slime-failed-tests 0)) (loop for (name function inputs) in slime-tests - do (dolist (input inputs) - (incf slime-total-tests) - (princ (format "%s: %S\n" name input)) - (condition-case err - (apply function input) - (error (incf slime-failed-tests) - (slime-print-check-error err))))) - (if (zerop slime-failed-tests) - (message "All %S tests completed successfully." slime-total-tests) - (message "Failed on %S of %S tests." - slime-failed-tests slime-total-tests))))) - -(defun slime-batch-test () - "Run the test suite in batch-mode." - (let ((standard-output t) + do (progn + (slime-test-heading 1 "%s" name) + (dolist (input inputs) + (incf slime-total-tests) + (slime-test-heading 2 "input: %s" input) + (condition-case err + (apply function input) + (error (incf slime-failed-tests) + (slime-print-check-error err)))))) + (let ((summary (if (zerop slime-failed-tests) + (format "All %S tests completed successfully." + slime-total-tests) + (format "Failed on %S of %S tests." + slime-failed-tests slime-total-tests)))) + (save-excursion + (with-current-buffer slime-test-buffer-name + (goto-char (point-min)) + (insert summary "\n\n"))) + (message summary) + slime-failed-tests)))) + +(defun slime-batch-test (results-file) + "Run the test suite in batch-mode. +Exits Emacs when finished. The exit code is the number of failed tests." + (let ((slime-dont-prompt t) + (slime-swank-port 4006) ; different port than interactive use (slime-test-debug-on-error nil)) (slime) - (slime-run-tests))) + (switch-to-buffer "*scratch*") + (let ((failed-tests (slime-run-tests))) + (with-current-buffer slime-test-buffer-name + (slime-delete-hidden-outline-text) + (goto-char (point-min)) + (insert "-*- outline -*-\n\n") + (write-file results-file)) + (kill-emacs failed-tests)))) + + +;;;;; Results buffer creation and output + +(defun slime-create-test-results-buffer () + "Create and initialize the buffer for test suite results." + (ignore-errors (kill-buffer slime-test-buffer-name)) + (with-current-buffer (get-buffer-create slime-test-buffer-name) + (erase-buffer) + (outline-mode) + (set (make-local-variable 'outline-regexp) "\\*+") + (set (make-local-variable 'truncate-lines) t))) + +(defun slime-delete-hidden-outline-text () + "Delete the hidden parts of an outline-mode buffer." + (loop do (when (eq (get-char-property (point) 'invisible) 'outline) + (delete-region (point) + (next-single-char-property-change (point) + 'invisible))) + until (eobp) + do (goto-char (next-single-char-property-change (point) 'invisible)))) + +(defun slime-test-heading (level format &rest args) + "Output a test suite heading. +LEVEL gives the depth of nesting: 1 for top-level, 2 for a subheading, etc." + (with-current-buffer slime-test-buffer-name + (goto-char (point-max)) + (insert (make-string level ?*) + " " + (apply 'format format args) + "\n"))) + +(defun slime-test-failure (keyword string) + "Output a failure message from the test suite. +KEYWORD names the type of failure and STRING describes the reason." + (with-current-buffer slime-test-buffer-name + (goto-char (point-max)) + (let ((start (point))) + (insert keyword ": ") + (let ((overlay (make-overlay start (point)))) + (overlay-put overlay 'slime-failed-test t) + (overlay-put overlay 'face 'bold))) + (insert string "\n"))) + +(defun slime-test-message (string) + "Output a message from the test suite." + (with-current-buffer slime-test-buffer-name + (goto-char (point-max)) + (insert string "\n"))) + + +;;;;; Macros for defining test cases (defmacro def-slime-test (name args doc inputs &rest body) "Define a test case. @@ -2315,24 +2470,35 @@ (list (list ',name ',fname ,inputs))))))) (defmacro slime-check (test-name &rest body) - `(if (progn , at body) - (slime-print-check-ok ',test-name) - (incf slime-failed-tests) - (slime-print-check-failed ',test-name) - (when slime-test-debug-on-error - (debug (format "Check failed: %S" ',test-name))))) + "Check a condition (assertion.) +TEST-NAME can be a symbol, a string, or a (FORMAT-STRING . ARGS) list. +BODY returns true if the check succeeds." + (let ((check-name (gensym "check-name-"))) + `(let ((,check-name ,(typecase test-name + (symbol (symbol-name test-name)) + (string test-name) + (cons `(format , at test-name))))) + (if (progn , at body) + (slime-print-check-ok ,check-name) + (incf slime-failed-tests) + (slime-print-check-failed ,check-name) + (when slime-test-debug-on-error + (debug (format "Check failed: %S" ,check-name))))))) (defun slime-print-check-ok (test-name) - (when slime-test-verbose-p - (princ (format " ok: %s\n" test-name)))) + (slime-test-message test-name)) (defun slime-print-check-failed (test-name) - (slime-princ-propertized (format " FAILED: %s\n" test-name) - '(face font-lock-warning-face))) + (slime-test-failure "FAILED" test-name)) (defun slime-print-check-error (reason) - (slime-princ-propertized (format " ERROR: %S\n" reason) - '(face font-lock-warning-face))) + (slime-test-failure "ERROR" (format "%S" reason))) + +(put 'def-slime-test 'lisp-indent-function 4) +(put 'slime-check 'lisp-indent-function 1) + + +;;;;; Test case definitions. ;; Clear out old tests. (setq slime-tests nil) @@ -2347,13 +2513,13 @@ (orig-pos (point))) (slime-edit-fdefinition (symbol-name name)) ;; Postconditions - (slime-check correct-file + (slime-check ("Definition of `%S' is in %S." name expected-filename) (string= (file-name-nondirectory (buffer-file-name)) expected-filename)) - (slime-check looking-at-definition + (slime-check "Definition now at point." (looking-at (format "(\\(defun\\|defmacro\\)\\s *%s\\s " name))) (slime-pop-find-definition-stack) - (slime-check return-from-definition + (slime-check "Returning from definition restores original buffer/position." (and (eq orig-buffer (current-buffer)) (= orig-pos (point)))))) @@ -2366,20 +2532,19 @@ ("cl:foobar" nil) ("cl::compile-file" ("cl::compile-file" "cl::compile-file-pathname"))) (let ((completions (slime-completions prefix))) - (slime-check expected-completions + (slime-check "Completion set is as expected." (equal expected-completions (sort completions 'string<))))) (def-slime-test arglist - (symbol expected-arglist) - "Lookup the argument list for SYMBOL. + (function-name expected-arglist) + "Lookup the argument list for FUNCTION-NAME. Confirm that EXPECTED-ARGLIST is displayed." '(("list" "(list &rest args)") ("defun" "(defun &whole source name lambda-list &parse-body (body decls doc))") ("cl::defun" "(cl::defun &whole source name lambda-list &parse-body (body decls doc))")) - (slime-arglist symbol) - (slime-sync) - (slime-check expected-arglist - (string= expected-arglist (current-message)))) + (let ((arglist (slime-get-arglist function-name))) ; + (slime-check ("Argument list %S is as expected." arglist) + (string= expected-arglist arglist)))) (def-slime-test compile-defun (program subform) @@ -2391,9 +2556,10 @@ ;;Sdf (:bar))" (:bar)) - ;; this fails ("(defun :foo () - #| |# + #+(or)skipped + #| #||# + #||# |# (:bar))" (:bar)) ) @@ -2407,8 +2573,51 @@ (equal (read (current-buffer)) subform)))) -(put 'def-slime-test 'lisp-indent-function 4) -(put 'slime-check 'lisp-indent-function 1) +(def-slime-test async-eval-debugging (depth) + "Test recursive debugging of asynchronous evaluation requests." + '((1) (2) (3)) + (slime-check "Automaton initially in idle state." + ;; We expect to be at the top-level when the test starts. + (slime-test-state-stack '(slime-idle-state))) + (lexical-let ((depth depth) + (debug-hook-max-depth 0)) + (let ((debug-hook + (lambda () + (when (> sldb-level debug-hook-max-depth) + (setq debug-hook-max-depth sldb-level) + (slime-check + ("Automaton stack reflects debug level %S." sldb-level) + ;; Inspect the stack to ensure we are debugging at the + ;; expected recursion depth. + (let ((expected-stack '(slime-idle-state))) + (dotimes (i sldb-level) + (push 'slime-evaluating-state expected-stack) + (push 'slime-debugging-state expected-stack)) + (slime-test-state-stack expected-stack))) + (if (= sldb-level depth) + ;; We're at maximum recursion - time to unwind + (sldb-quit) + ;; Going down - enter another recursive debug + ;; Recursively debug. + (slime-eval-async 'no-such-variable nil (lambda (_) nil)) + (slime-sync)))))) + (let ((sldb-hook (cons debug-hook sldb-hook))) + (slime-eval-async 'no-such-variable nil (lambda (_) nil)) + (slime-sync) + ;; Now the hook should have run once for each , + (slime-check ("Maximum depth reached (%S) is %S." + debug-hook-max-depth depth) + (= debug-hook-max-depth depth)) + ;; FIXME: synchronize properly somehow. We are expecting Lisp + ;; to perform a restart and unwind our stack. + (sit-for 2) + ;; and the restart should have put us back at the top level + (slime-check "Automaton is back in idle state." + (slime-test-state-stack '(slime-idle-state))))))) + +(defun slime-test-state-stack (states) + "True if STATES describes the current stack of states." + (equal states (mapcar #'slime-state-name slime-state-stack))) ;;; Portability library From lgorrie at common-lisp.net Wed Oct 15 14:44:05 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 15 Oct 2003 10:44:05 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31803 Modified Files: ChangeLog Log Message: Date: Wed Oct 15 10:44:05 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.23 slime/ChangeLog:1.24 --- slime/ChangeLog:1.23 Wed Oct 15 10:17:52 2003 +++ slime/ChangeLog Wed Oct 15 10:44:05 2003 @@ -1,3 +1,29 @@ +2003-10-15 Luke Gorrie + + * test.sh: New file to run the test suite in batch-mode. Will need + a little extending to allow configuring the right variables to + work with non-CMUCL backends. + + * slime.el: Set `indent-tabs-mode' to nil. This makes diffs look + better. + (slime-start-swank-server): Now passing the port number of + SWANK:START-SERVER. + (slime-evaluating-state): Debugging synchronous evaluations with + recursive edits now works. + (slime-forward-sexp): Added support for #|...|# reading comments. + (sldb-hook): New hook for entry to the debugger (used for the test + suite). + (slime-run-tests): Reworked the testing framework. Now presents + results in an outline-mode buffer, with only the subtrees + containing failed tests expanded initially. + (slime-check): Check-name can now be a string or + format-control. (Test cases have been updated to take advantage of + this.) + (compile-defun): This test case now works for the case containing + #|..|# + (async-eval-debugging): New test case for recursively debugging + asynchronous evaluation. + 2003-10-15 Daniel Barlow * swank-sbcl.lisp: new file. From lgorrie at common-lisp.net Wed Oct 15 14:44:12 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 15 Oct 2003 10:44:12 -0400 Subject: [slime-cvs] CVS update: slime/test.sh Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31864 Added Files: test.sh Log Message: Date: Wed Oct 15 10:44:11 2003 Author: lgorrie From dbarlow at common-lisp.net Wed Oct 15 14:59:05 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Wed, 15 Oct 2003 10:59:05 -0400 Subject: [slime-cvs] CVS update: slime/README.sbcl slime/ChangeLog slime/README Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6354 Modified Files: ChangeLog README Added Files: README.sbcl Log Message: Updated verbiage to reflect multiple backends and change of hosting provider Date: Wed Oct 15 10:59:05 2003 Author: dbarlow Index: slime/ChangeLog diff -u slime/ChangeLog:1.24 slime/ChangeLog:1.25 --- slime/ChangeLog:1.24 Wed Oct 15 10:44:05 2003 +++ slime/ChangeLog Wed Oct 15 10:59:05 2003 @@ -26,6 +26,10 @@ 2003-10-15 Daniel Barlow + * README.sbcl: new file + + * README: update for new backends, change of hosting provider + * swank-sbcl.lisp: new file. New SWANK backend for Steel Bank Common Lisp, adapted from swank.lisp with bits of swank-openmcl.lisp Index: slime/README diff -u slime/README:1.3 slime/README:1.4 --- slime/README:1.3 Fri Sep 26 15:37:37 2003 +++ slime/README Wed Oct 15 10:59:05 2003 @@ -3,11 +3,13 @@ SLIME is the Superior Lisp Interaction Mode (which has been Extended). It is implemented in two main parts: the Emacs Lisp side - (slime.el), and the support library for CMUCL (swank.lisp). + (slime.el), and the support library for the Common Lisp + (swank.lisp for CMUCL, swank-sbcl.lisp, swank-openmcl.lisp for + the others) For a real description, see the commentary in slime.el. -Quick setup instructions. +Quick setup instructions for CMUCL ---------------------------------------- In Emacs Lisp: @@ -27,17 +29,22 @@ ---------------------------------------- The Emacs Lisp code is licensed under the GNU GPL to fit in with Emacs. - The CMUCL code is placed in the public domain to fit in with CMUCL. + + The CMUCL and SBCL code is placed in the public domain to fit in with + CMUCL and SBCL + + The OpenMCL code is LLGPLed, just like OpenMCL Contact. ---------------------------------------- - SLIME is maintained by Luke Gorrie and Helmut Eller. It is an - Extension of SLIM by Eric Marsden (unreleased). + SLIME is maintained by Luke Gorrie, Helmut Eller, and Daniel + Barlow. It is an Extension of SLIM by Eric Marsden (unreleased). Questions and comments are best directed to the mailing list: - http://lists.sourceforge.net/lists/listinfo/slime-devel + http://common-lisp.net/mailman/listinfo/slime-devel - The mailing list archive is now on Gmane: + The mailing list archive was once on Gmane, and soon will be again, + when they catch up with our change of project hosting provider http://news.gmane.org/gmane.lisp.slime.devel From lgorrie at common-lisp.net Wed Oct 15 14:59:26 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 15 Oct 2003 10:59:26 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7734 Modified Files: slime.el Log Message: (slime-point-moves-p): Macro for executing subforms and returning true if they move the point. Date: Wed Oct 15 10:59:26 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.31 slime/slime.el:1.32 --- slime/slime.el:1.31 Wed Oct 15 10:43:56 2003 +++ slime/slime.el Wed Oct 15 10:59:26 2003 @@ -1191,6 +1191,15 @@ (t (error "Unsupported location type %s" note)))) +(defmacro slime-point-moves-p (&rest body) + "Execute BODY and return true if the current buffer's point moved." + (let ((pointvar (gensym "point-"))) + `(let ((,pointvar (point))) + (save-current-buffer , at body) + (/= ,pointvar (point))))) + +(put 'slime-point-moves-p 'lisp-indent-function 0) + (defun slime-forward-sexp (&optional count) "Like `forward-sexp', but understands reader-conditionals (#- and #+)." (dotimes (i (or count 1)) From lgorrie at common-lisp.net Wed Oct 15 15:01:59 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 15 Oct 2003 11:01:59 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9041 Modified Files: ChangeLog Log Message: Date: Wed Oct 15 11:01:58 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.25 slime/ChangeLog:1.26 --- slime/ChangeLog:1.25 Wed Oct 15 10:59:05 2003 +++ slime/ChangeLog Wed Oct 15 11:01:58 2003 @@ -1,5 +1,8 @@ 2003-10-15 Luke Gorrie + * slime.el (slime-point-moves-p): Macro for executing subforms and + returning true if they move the point. + * test.sh: New file to run the test suite in batch-mode. Will need a little extending to allow configuring the right variables to work with non-CMUCL backends. From lgorrie at common-lisp.net Wed Oct 15 16:19:30 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 15 Oct 2003 12:19:30 -0400 Subject: [slime-cvs] CVS update: slime/README Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23490 Modified Files: README Log Message: More updates. Date: Wed Oct 15 12:19:30 2003 Author: lgorrie Index: slime/README diff -u slime/README:1.4 slime/README:1.5 --- slime/README:1.4 Wed Oct 15 10:59:05 2003 +++ slime/README Wed Oct 15 12:19:30 2003 @@ -1,11 +1,10 @@ Overview. ---------------------------------------- - SLIME is the Superior Lisp Interaction Mode (which has been - Extended). It is implemented in two main parts: the Emacs Lisp side - (slime.el), and the support library for the Common Lisp - (swank.lisp for CMUCL, swank-sbcl.lisp, swank-openmcl.lisp for - the others) + SLIME is the Superior Lisp Interaction Mode for Emacs. It is + implemented in two main parts: the Emacs Lisp side (slime.el), and + the support library for the Common Lisp (swank.lisp for CMUCL, + swank-sbcl.lisp, swank-openmcl.lisp for the others) For a real description, see the commentary in slime.el. @@ -18,10 +17,13 @@ (require 'slime) (add-hook 'lisp-mode-hook (lambda () (slime-mode t))) - Make sure your `inferior-lisp-program' is set to a recent (post-18e) - version of CMUCL. + Make sure your `inferior-lisp-program' is set to a compatible + version of Lisp. For CMUCL we currently require a post-18e + snapshot. If you use a non-CMUCL backend, you will need to customize + the elisp variable `slime-backend' and possibly + `slime-lisp-binary-extension' too. - M-x slime to fire up an inferior Lisp. + Use `M-x' slime to fire up and connect to an inferior Lisp. Open a lisp-mode file and do `C-h m' to see the mode description. @@ -30,16 +32,16 @@ The Emacs Lisp code is licensed under the GNU GPL to fit in with Emacs. - The CMUCL and SBCL code is placed in the public domain to fit in with - CMUCL and SBCL + The CMUCL and SBCL code is placed in the public domain to fit in + with CMUCL and SBCL. - The OpenMCL code is LLGPLed, just like OpenMCL + The OpenMCL code is LLGPLed, just like OpenMCL. Contact. ---------------------------------------- - SLIME is maintained by Luke Gorrie, Helmut Eller, and Daniel - Barlow. It is an Extension of SLIM by Eric Marsden (unreleased). + SLIME is maintained by Luke Gorrie, Helmut Eller, James Bielman, + and Daniel Barlow. It is an Extension of SLIM by Eric Marsden (unreleased). Questions and comments are best directed to the mailing list: http://common-lisp.net/mailman/listinfo/slime-devel From lgorrie at common-lisp.net Wed Oct 15 16:23:44 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 15 Oct 2003 12:23:44 -0400 Subject: [slime-cvs] CVS update: slime/README Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26527 Modified Files: README Log Message: Added note about FAIRLY-STABLE tag. Date: Wed Oct 15 12:23:44 2003 Author: lgorrie Index: slime/README diff -u slime/README:1.5 slime/README:1.6 --- slime/README:1.5 Wed Oct 15 12:19:30 2003 +++ slime/README Wed Oct 15 12:23:44 2003 @@ -27,6 +27,13 @@ Open a lisp-mode file and do `C-h m' to see the mode description. + If you have bad luck, you may checkout a copy of SLIME that is + completely broken, depending on what's happening in CVS at the + time. To avoid this you can checkout from the CVS tag + `FAIRLY-STABLE' like this: + + cvs checkout -r FAIRLY-STABLE slime + Licence. ---------------------------------------- From lgorrie at common-lisp.net Wed Oct 15 16:56:51 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 15 Oct 2003 12:56:51 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv24240 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Oct 15 12:56:51 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.26 slime/ChangeLog:1.27 --- slime/ChangeLog:1.26 Wed Oct 15 11:01:58 2003 +++ slime/ChangeLog Wed Oct 15 12:56:51 2003 @@ -13,7 +13,7 @@ SWANK:START-SERVER. (slime-evaluating-state): Debugging synchronous evaluations with recursive edits now works. - (slime-forward-sexp): Added support for #|...|# reading comments. + (slime-forward-sexp): Added support for #|...|# reader comments. (sldb-hook): New hook for entry to the debugger (used for the test suite). (slime-run-tests): Reworked the testing framework. Now presents From heller at common-lisp.net Wed Oct 15 17:30:14 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 15 Oct 2003 13:30:14 -0400 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18613 Modified Files: swank.lisp Log Message: *swank-io-package*: Import t and quote. (prin1-to-string-for-emacs): Use standard-io-syntax. (*previous-compiler-condition*, *previous-context*, handle-notification-condition, clear-compiler-notes, compiler-note-for-emacs, minimal-compiler-note-for-emacs, severity-for-emacs): Try to deal with error messages without context info. (list-callers, list-callees): Find callers by inspecting the constant pool of code components. (find-fdefinition, function-debug-info, fdefinition-file, code-definition-file): Deleted. Inspector support. Date: Wed Oct 15 13:30:14 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.25 slime/swank.lisp:1.26 --- slime/swank.lisp:1.25 Sun Sep 28 18:38:40 2003 +++ slime/swank.lisp Wed Oct 15 13:30:14 2003 @@ -1,3 +1,4 @@ + (declaim (optimize debug)) (defpackage :swank @@ -26,6 +27,8 @@ #:who-sets #:who-binds #:who-macroexpands + #:list-callers + #:list-callees #:list-all-package-names #:function-source-location-for-emacs #:swank-macroexpand-1 @@ -51,6 +54,12 @@ #:sldb-abort #:sldb-continue #:throw-to-toplevel + #:init-inspector + #:inspect-nth-part + #:inspector-pop + #:inspector-next + #:describe-inspectee + #:quit-inspector )) (in-package :swank) @@ -137,6 +146,7 @@ :input (lambda (fd) (declare (ignore fd)) (serve-request stream output))))) + (defun serve-request (*emacs-io* *slime-output*) "Read and process a request from a SWANK client. The request is read from the socket as a sexp and then evaluated." @@ -164,7 +174,7 @@ (defvar *swank-io-package* (let ((package (make-package "SWANK-IO-PACKAGE"))) - (import 'nil package) + (import '(nil t quote) package) package)) (defun read-form (string) @@ -197,11 +207,12 @@ (force-output *emacs-io*))) (defun prin1-to-string-for-emacs (object) - (let ((*print-case* :downcase) - (*print-readably* t) - (*print-pretty* nil) - (*package* *swank-io-package*)) - (prin1-to-string object))) + (with-standard-io-syntax + (let ((*print-case* :downcase) + (*print-readably* t) + (*print-pretty* nil) + (*package* *swank-io-package*)) + (prin1-to-string object)))) ;;; Functions for Emacs to call. @@ -315,7 +326,11 @@ (defvar *compiler-notes* '() "List of compiler notes for the last compilation unit.") -(defun clear-compiler-notes () (setf *compiler-notes* '())) +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Used for compiler warnings without context.") (defvar *notes-database* (make-hash-table :test #'equal) "Database of recorded compiler notes/warnings/erros (keyed by filename). @@ -325,43 +340,66 @@ MESSAGE is a string describing the note. CONTEXT is a string giving further details of where the error occured.") +(defun clear-compiler-notes () + (setf *compiler-notes* '()) + (setf *previous-compiler-condition* nil) + (setf *previous-context* nil)) + (defun clear-note-database (filename) (remhash (canonicalize-filename filename) *notes-database*)) (defvar *buffername*) (defvar *buffer-offset*) -(defvar *previous-compiler-condition* nil - "Used to detect duplicates.") - (defun handle-notification-condition (condition) "Handle a condition caused by a compiler warning. This traps all compiler conditions at a lower-level than using C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to craft our own error messages, which can omit a lot of redundant information." - (let ((context (c::find-error-context nil))) - (when (and context (not (eq condition *previous-compiler-condition*))) + (unless (eq condition *previous-compiler-condition*) + (let ((context (or (c::find-error-context nil) *previous-context*))) (setq *previous-compiler-condition* condition) - (let* ((file-name (c::compiler-error-context-file-name context)) - (file-pos (c::compiler-error-context-file-position context)) - (file (if (typep file-name 'pathname) - (unix-truename file-name) - file-name)) - (note - (list - :position file-pos - :filename (and (stringp file) file) - :source-path (current-compiler-error-source-path) - :severity (etypecase condition - (c::compiler-error :error) - (c::style-warning :note) - (c::warning :warning)) - :message (brief-compiler-message-for-emacs condition context) - :buffername (if (boundp '*buffername*) *buffername*) - :buffer-offset (if (boundp '*buffer-offset*) *buffer-offset*)))) - (push note *compiler-notes*) - (push note (gethash file *notes-database*)))))) + (setq *previous-context* context) + (let ((note (if context + (compiler-note-for-emacs condition context) + (minimal-compiler-note-for-emacs condition)))) + (push note *compiler-notes*) + (when *compile-file-truename* + (push note (gethash (namestring *compile-file-truename*) + *notes-database*))))))) + +(defun compiler-note-for-emacs (condition context) + (let* ((file-name (c::compiler-error-context-file-name context)) + (file-position (c::compiler-error-context-file-position context)) + (file (if (typep file-name 'pathname) + (unix-truename file-name) + file-name))) + (list + :position file-position + :filename (and (stringp file) file) + :source-path (current-compiler-error-source-path context) + :severity (severity-for-emacs condition) + :message (brief-compiler-message-for-emacs condition context) + :buffername (if (boundp '*buffername*) *buffername*) + :buffer-offset (if (boundp '*buffer-offset*) *buffer-offset*)))) + +(defun minimal-compiler-note-for-emacs (condition) + "Return compiler note with only minimal context information." + (list :position 0 + :filename (if *compile-file-truename* + (namestring *compile-file-truename*)) + :source-path nil + :severity (severity-for-emacs condition) + :message (princ-to-string condition) + :buffername (if (boundp '*buffername*) *buffername*) + :buffer-offset (if (boundp '*buffer-offset*) *buffer-offset*))) + +(defun severity-for-emacs (condition) + (etypecase condition + (c::compiler-error :error) + (c::style-warning :note) + (c::warning :warning))) (defun brief-compiler-message-for-emacs (condition error-context) "Briefly describe a compiler error for Emacs. @@ -374,17 +412,16 @@ (format nil "--> ~{~<~%--> ~1:;~A~> ~}~%~A" enclosing condition) (format nil "~A" condition)))) -(defun current-compiler-error-source-path () +(defun current-compiler-error-source-path (context) "Return the source-path for the current compiler error. Returns NIL if this cannot be determined by examining internal compiler state." - (let ((context c::*compiler-error-context*)) - (cond ((c::node-p context) - (reverse - (c::source-path-original-source (c::node-source-path context)))) - ((c::compiler-error-context-p context) - (reverse - (c::compiler-error-context-original-source-path context)))))) + (cond ((c::node-p context) + (reverse + (c::source-path-original-source (c::node-source-path context)))) + ((c::compiler-error-context-p context) + (reverse + (c::compiler-error-context-original-source-path context))))) (defslimefun features () (mapcar #'symbol-name *features*)) @@ -421,8 +458,8 @@ (defun call-with-compilation-hooks (fn) (multiple-value-bind (result usecs) (with-trapping-compilation-notes () - (clear-compiler-notes) - (measure-time-intervall fn)) + (clear-compiler-notes) + (measure-time-intervall fn)) (list (to-string result) (format nil "~,2F" (/ usecs 1000000.0))))) @@ -567,6 +604,89 @@ (and (every #'< path1 path2) (< (length path1) (length path2)))) +;;; Find callers and callees by looking at the constant pool of +;;; compiled code objects. We assume every fdefn object in the +;;; constant pool corresponds to a call to that function. A better +;;; strategy would be to use the disassembler to find actual +;;; call-sites. + +(declaim (inline map-code-constants)) +(defun map-code-constants (code fn) + "Call FN for each constant in CODE's constant pool." + (check-type code kernel:code-component) + (loop for i from vm:code-constants-offset below (kernel:get-header-data code) + do (funcall fn (kernel:code-header-ref code i)))) + +(defun function-callees (function) + "Return FUNCTION's callees as a list of names." + (let ((callees '())) + (map-code-constants + (vm::find-code-object function) + (lambda (obj) + (when (kernel:fdefn-p obj) + (push (kernel:fdefn-name obj) + callees)))) + callees)) + +(declaim (inline map-allocated-code-components)) +(defun map-allocated-code-components (spaces fn) + "Call FN for each allocated code component in one of SPACES. FN +receives the object and it's size as arguments. SPACES should be a +list of the symbols :dynamic, :static, or :read-only." + (dolist (space spaces) + (vm::map-allocated-objects + (lambda (obj header size) + (when (= vm:code-header-type header) + (funcall fn obj size))) + space))) + +(declaim (inline map-caller-code-components)) +(defun map-caller-code-components (function spaces fn) + "Call FN for each code component with a fdefn for FUNCTION in its +constant pool." + (let ((function (coerce function 'function))) + (map-allocated-code-components + spaces + (lambda (obj size) + (declare (ignore size)) + (map-code-constants + obj + (lambda (constant) + (when (and (kernel:fdefn-p constant) + (eq (kernel:fdefn-function constant) + function)) + (funcall fn obj)))))))) + +(defun function-callers (function &optional (spaces '(:read-only :static + :dynamic))) + "Return FUNCTION's callers as a list of names." + (let ((referrers '())) + (map-caller-code-components + function + spaces + (lambda (code) + (let ((entry (kernel:%code-entry-points code))) + (cond ((not entry) + (push (princ-to-string code) referrers)) + (t + (loop for e = entry then (kernel::%function-next e) + while e + for name = (kernel:%function-name e) + do (pushnew name referrers :test #'equal))))))) + referrers)) + +(defun stringify-function-name-list (list) + (let ((*print-pretty* nil)) + (mapcar #'to-string (remove-if-not #'ext:valid-function-name-p list)))) + +(defslimefun list-callers (symbol-name) + (stringify-function-name-list (function-callers (from-string symbol-name)))) + +(defslimefun list-callees (symbol-name) + (stringify-function-name-list (function-callees (from-string symbol-name)))) + +;;; + (defslimefun completions (string default-package-name) "Return a list of completions for a symbol designator STRING. @@ -618,7 +738,7 @@ (defslimefun list-all-package-names () (let ((list '())) (maphash (lambda (name package) - (declare (ignore package)) + (declare (ignore package)) (pushnew name list)) lisp::*package-names*) list)) @@ -629,91 +749,58 @@ "When true don't handle errors while looking for definitions. This is useful when debugging the definition-finding code.") -;;; FIND-FDEFINITION -- interface -;;; -(defslimefun find-fdefinition (symbol-name package-name) - "Return the name of the file in which the function was defined, or NIL." - (fdefinition-file (read-symbol/package symbol-name package-name))) - -(defun function-debug-info (function) - "Return the debug-info for FUNCTION." - (declare (type (or symbol function) function)) - (typecase function - (symbol - (let ((def (or (macro-function function) - (and (fboundp function) - (fdefinition function))))) - (when def (function-debug-info def)))) - (kernel:byte-closure - (function-debug-info (kernel:byte-closure-function function))) - (kernel:byte-function - (kernel:%code-debug-info (c::byte-function-component function))) - (function - (kernel:%code-debug-info (kernel:function-code-header - (kernel:%function-self function)))) - (t nil))) - (defun function-first-code-location (function) (and (function-has-debug-function-p function) (di:debug-function-start-location (di:function-debug-function function)))) -(defun function-debug-function-name (function) - (and (function-has-debug-function-p function) - (di:debug-function-name (di:function-debug-function function)))) - (defun function-has-debug-function-p (function) (di:function-debug-function function)) -(defun function-debug-function-name= (function name) - (equal (function-debug-function-name function) name)) +(defun function-code-object= (closure function) + (and (eq (vm::find-code-object closure) + (vm::find-code-object function)) + (not (eq closure function)))) (defun struct-accessor-p (function) - (function-debug-function-name= function "DEFUN STRUCTURE-SLOT-ACCESSOR")) + (function-code-object= function #'kernel::structure-slot-accessor)) -(defun struct-accessor-class (function) - (kernel:%closure-index-ref function 0)) +(defun struct-accessor-dd (function) + (kernel:layout-info (kernel:%closure-index-ref function 2))) -(defun struct-setter-p (function) - (function-debug-function-name= function "DEFUN STRUCTURE-SLOT-SETTER")) +(defun struct-misc-op-p (function) + (function-code-object= function #'kernel::%defstruct)) -(defun struct-setter-class (function) - (kernel:%closure-index-ref function 0)) - -(defun struct-predicate-p (function) - (function-debug-function-name= function "DEFUN %DEFSTRUCT")) - -(defun struct-predicate-class (function) - (kernel:layout-class +(defun struct-misc-op-dd (function) + (assert (= (kernel:get-type function) vm:closure-header-type)) + (kernel:layout-info (c:value-cell-ref - (kernel:%closure-index-ref function 0)))) + (sys:find-if-in-closure #'di::indirect-value-cell-p function)))) -(defun struct-class-source-location (class) - (let ((constructor (kernel::structure-class-constructor class))) - (cond (constructor (function-source-location constructor)) - (t (error "Cannot locate struct without constructor: ~A" class))))) +(defun dd-source-location (dd) + (let ((constructor (or (kernel:dd-default-constructor dd) + (car (kernel::dd-constructors dd))))) + (cond (constructor + (function-source-location + (coerce (if (consp constructor) (car constructor) constructor) + 'function))) + (t (error "Cannot locate struct without constructor: ~S" + (kernel::dd-name dd)))))) (defun function-source-location (function) "Try to find the canonical source location of FUNCTION." ;; First test if FUNCTION is a closure created by defstruct; if so - ;; extract the struct-class from the closure and find the - ;; constructor for the struct-class. Defstruct creates a defun for + ;; extract the defstruct-description (dd) from the closure and find + ;; the constructor for the struct. Defstruct creates a defun for ;; the default constructor and we use that as an approximation to - ;; the source location of the defstruct. Unfortunately, some - ;; defstructs have no or non-default constructors, in that case we - ;; are out of luck. + ;; the source location of the defstruct. ;; ;; For an ordinary function we return the source location of the ;; first code-location we find. (cond ((struct-accessor-p function) - (struct-class-source-location - (struct-accessor-class function))) - ((struct-setter-p function) - (struct-class-source-location - (struct-setter-class function))) - ((struct-predicate-p function) - (struct-class-source-location - (struct-predicate-class function))) + (dd-source-location (struct-accessor-dd function))) + ((struct-misc-op-p function) + (dd-source-location (struct-misc-op-dd function))) (t (let ((location (function-first-code-location function))) (when location @@ -733,36 +820,7 @@ (handler-case (funcall finder) (error (e) (list :error (format nil "Error: ~A" e))))))) -;;; Clone of HEMLOCK-INTERNALS::FUN-DEFINED-FROM-PATHNAME -(defun fdefinition-file (function) - "Return the name of the file in which FUNCTION was defined." - (declare (type (or symbol function) function)) - (typecase function - (symbol - (let ((def (or (macro-function function) - (and (fboundp function) - (fdefinition function))))) - (when def (fdefinition-file def)))) - (kernel:byte-closure - (fdefinition-file (kernel:byte-closure-function function))) - (kernel:byte-function - (code-definition-file (c::byte-function-component function))) - (function - (code-definition-file (kernel:function-code-header - (kernel:%function-self function)))) - (t nil))) - -(defun code-definition-file (code) - "Return the name of the file in which CODE was defined." - (declare (type kernel:code-component code)) - (flet ((to-namestring (pathname) - (handler-case (namestring (truename pathname)) - (file-error () nil)))) - (let ((info (kernel:%code-debug-info code))) - (when info - (let ((source (car (c::debug-info-source info)))) - (when (and source (eq (c::debug-source-from source) :file)) - (to-namestring (c::debug-source-name source)))))))) +;;; (defun briefly-describe-symbol-for-emacs (symbol) "Return a plist describing SYMBOL. @@ -882,9 +940,9 @@ (defslimefun swank-macroexpand-all (string) (apply-macro-expander #'walker:macroexpand-all string)) - ;;; + (defun tracedp (fname) (gethash (debug::trace-fdefinition fname) debug::*traced-functions*)) @@ -944,7 +1002,7 @@ (unwind-protect (loop (catch 'sldb-loop-catcher - (with-simple-restart (abort "Return to sldb level ~D." level) + (with-simple-restart (abort "Return to sldb level ~D." level) (read-from-emacs)))) (send-to-emacs `(:debug-return ,level)))))) @@ -985,13 +1043,10 @@ continuing to frame number END or, if END is nil, the last frame on the stack." (let ((end (or end most-positive-fixnum))) - (do ((frame *sldb-stack-top* (di:frame-down frame)) - (i 0 (1+ i))) - ((= i start) - (loop for f = frame then (di:frame-down f) - for i from start below end - while f - collect f))))) + (loop for f = (nth-frame start) then (di:frame-down f) + for i from start below end + while f + collect f))) (defslimefun backtrace-for-emacs (start end) (mapcar #'format-frame-for-emacs (compute-backtrace start end))) @@ -1091,6 +1146,205 @@ (defslimefun throw-to-toplevel () (throw 'lisp::top-level-catcher nil)) + + +;;; Inspecting + +(defvar *inspectee*) +(defvar *inspectee-parts*) +(defvar *inspector-stack* '()) +(defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)) +(defvar *inspect-length* 30) + +(defun reset-inspector () + (setq *inspectee* nil) + (setq *inspectee-parts* nil) + (setq *inspector-stack* nil) + (setf (fill-pointer *inspector-history*) 0)) + +(defslimefun init-inspector (string) + (reset-inspector) + (inspect-object (eval (from-string string)))) + +(defun print-part-to-string (value) + (let ((*print-pretty* nil)) + (let ((string (to-string value)) + (pos (position value *inspector-history*))) + (if pos + (format nil "#~D=~A" pos string) + string)))) + +(defun inspect-object (object) + (push (setq *inspectee* object) *inspector-stack*) + (unless (find object *inspector-history*) + (vector-push-extend object *inspector-history*)) + (multiple-value-bind (text parts) (inspected-parts object) + (setq *inspectee-parts* parts) + (list :text text + :type (to-string (type-of object)) + :primitive-type (describe-primitive-type object) + :parts (loop for (label . value) in parts + collect (cons label + (print-part-to-string value)))))) +(defconstant +lowtag-symbols+ + '(vm:even-fixnum-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:list-pointer-type + vm:odd-fixnum-type + vm:instance-pointer-type + vm:other-immediate-1-type + vm:other-pointer-type)) + +(defconstant +header-type-symbols+ + ;; Is there a convinient place for all those constants? + (flet ((tail-comp (string tail) + (and (>= (length string) (length tail)) + (string= string tail :start1 (- (length string) + (length tail)))))) + (remove-if-not + (lambda (x) (and (tail-comp (symbol-name x) "-TYPE") + (not (member x +lowtag-symbols+)) + (boundp x) + (typep (symbol-value x) 'fixnum))) + (append (apropos-list "-TYPE" "VM" t) + (apropos-list "-TYPE" "BIGNUM" t))))) + +(defun describe-primitive-type (object) + (with-output-to-string (*standard-output*) + (let* ((lowtag (kernel:get-lowtag object)) + (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) + (format t "[lowtag: ~A" lowtag-symbol) + (cond ((member lowtag (list vm:other-pointer-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:other-immediate-1-type + )) + (let* ((type (kernel:get-type object)) + (type-symbol (find type +header-type-symbols+ + :key #'symbol-value))) + (format t ", type: ~A]" type-symbol))) + (t (format t "]")))))) + +(defun nth-part (index) + (cdr (nth index *inspectee-parts*))) + +(defslimefun inspect-nth-part (index) + (inspect-object (nth-part index))) + +(defslimefun inspector-pop () + "Drop the inspector stack and inspect the second element. Return +nil if there's no second element." + (cond ((cdr *inspector-stack*) + (pop *inspector-stack*) + (inspect-object (pop *inspector-stack*))) + (t nil))) + +(defslimefun inspector-next () + "Inspect the next element in the *inspector-history*." + (let ((position (position *inspectee* *inspector-history*))) + (cond ((= (1+ position) (length *inspector-history*)) + nil) + (t (inspect-object (aref *inspector-history* (1+ position))))))) + +(defslimefun quit-inspector () + (reset-inspector) + nil) + +(defslimefun describe-inspectee () + "Describe the currently inspected object." + (print-desciption-to-string *inspectee*)) + +(defgeneric inspected-parts (object) + (:documentation + "Return a short description and a list of (label . value) pairs.")) + +(defmethod inspected-parts (o) + (cond ((di::indirect-value-cell-p o) + (inspected-parts-of-value-cell o)) + (t + (destructuring-bind (text labeledp . parts) + (inspect::describe-parts o) + (let ((parts (if labeledp + (loop for (label . value) in parts + collect (cons (string label) value)) + (loop for value in parts + for i from 0 + collect (cons (format nil "~D" i) value))))) + (values text parts)))))) + +(defun inspected-parts-of-value-cell (o) + (values (format nil "~A~% is a value cell." o) + (list (cons "Value" (c:value-cell-ref o))))) + +;; borrowed from sbcl +(defmethod inspected-parts ((object cons)) + (if (consp (cdr object)) + (inspected-parts-of-nontrivial-list object) + (inspected-parts-of-simple-cons object))) + +(defun inspected-parts-of-simple-cons (object) + (values "The object is a CONS." + (list (cons (string 'car) (car object)) + (cons (string 'cdr) (cdr object))))) + +(defun inspected-parts-of-nontrivial-list (object) + (let ((length 0) + (in-list object) + (reversed-elements nil)) + (flet ((done (description-format) + (return-from inspected-parts-of-nontrivial-list + (values (format nil description-format length) + (nreverse reversed-elements))))) + (loop + (cond ((null in-list) + (done "The object is a proper list of length ~S.~%")) + ((>= length *inspect-length*) + (push (cons (string 'rest) in-list) reversed-elements) + (done "The object is a long list (more than ~S elements).~%")) + ((consp in-list) + (push (cons (format nil "~D" length) (pop in-list)) + reversed-elements) + (incf length)) + (t + (push (cons (string 'rest) in-list) reversed-elements) + (done "The object is an improper list of length ~S.~%"))))))) + +(defmethod inspected-parts ((o function)) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (values + (format nil "~A~% is a function." o) + (list (cons "Self" (kernel:%function-self o)) + (cons "Next" (kernel:%function-next o)) + (cons "Name" (kernel:%function-name o)) + (cons "Arglist" (kernel:%function-arglist o)) + (cons "Type" (kernel:%function-type o)) + (cons "Code Object" (kernel:function-code-header o))))) + ((= header vm:closure-header-type) + (values (format nil "~A~% is a closure." o) + (list* + (cons "Function" (kernel:%closure-function o)) + (loop for i from 0 below (- (kernel:get-closure-length o) + (1- vm:closure-info-offset)) + collect (cons (format nil "~D" i) + (kernel:%closure-index-ref o i)))))) + (t (call-next-method o))))) + +(defmethod inspected-parts ((o kernel:code-component)) + (values (format nil "~A~% is a code data-block." o) + `(("First entry point" . ,(kernel:%code-entry-points o)) + ,@(loop for i from vm:code-constants-offset + below (kernel:get-header-data o) + collect (cons (format nil "Constant#~D" i) + (kernel:code-header-ref o i))) + ("Debug info" . ,(kernel:%code-debug-info o)) + ("Instructions" . ,(kernel:code-instructions o))))) + +(defmethod inspected-parts ((o kernel:fdefn)) + (values (format nil "~A~% is a fdefn object." o) + `(("Name" . ,(kernel:fdefn-name o)) + ("Function" . ,(kernel:fdefn-function o))))) ;;; Local Variables: ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) From heller at common-lisp.net Wed Oct 15 17:39:40 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 15 Oct 2003 13:39:40 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv24074 Modified Files: slime.el Log Message: (slime-inspect, slime-list-callers, slime-list-callees): New commands. (destructure-case): Avoid multiple otherwise cases (breaks in xemacs). (slime-make-state-function): Put inside a eval-when-compile. Inspector support. Date: Wed Oct 15 13:39:40 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.32 slime/slime.el:1.33 --- slime/slime.el:1.32 Wed Oct 15 10:59:26 2003 +++ slime/slime.el Wed Oct 15 13:39:40 2003 @@ -225,8 +225,11 @@ ("\C-c\C-wm" . slime-who-macroexpands) ;; Not sure which binding is best yet, so both for now. ([(control meta ?\.)] . slime-next-location) - ("\C-c\C- " . slime-next-location) - ("\C-c~" . slime-sync-package-and-default-directory) + ("\C-c\C- " . slime-next-location) + ("\C-c~" . slime-sync-package-and-default-directory) + ("\C-c\C-i" . slime-inspect) + ("\C-c<" . slime-list-callers) + ("\C-c>" . slime-list-callees) )) ;; Setup the mode-line to say when we're in slime-mode, and which CL @@ -289,10 +292,18 @@ `(,op (destructuring-bind ,rands ,operands . ,body))))) patterns) - (t (error "destructure-case failed: %S" ,tmp)))))) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (error "destructure-case failed: %S" ,tmp)))))))) (put 'destructure-case 'lisp-indent-function 1) +(defmacro slime-define-keys (keymap &rest key-command) + `(progn . ,(mapcar (lambda (k-c) `(define-key ,keymap . ,k-c)) + key-command))) + +(put 'slime-define-keys 'lisp-indent-function 1) + (defun slime-buffer-package (&optional dont-cache) "Return the Common Lisp package associated with the current buffer. This is heuristically determined by a text search of the buffer. @@ -739,6 +750,24 @@ ;;;;; Upper layer macros for defining states +(eval-when (compile eval) + (defun slime-make-state-function (arglist clauses) + "Build the function that implements a state. +The state's variables are moved into lexical bindings." + (let ((event-var (gensym "event-"))) + `(lexical-let ,(mapcar* #'list arglist arglist) + (lambda (,event-var) + (destructure-case ,event-var + , at clauses + ;; Every state can handle the event (activate). By default + ;; it does nothing. + ,@(if (member* '(activate) clauses :key #'car :test #'equal) + '() + '( ((activate) nil)) ) + (t (error "Can't handle event %S in state %S" + ,event-var + (slime-state-name (slime-current-state)))))))))) + (defmacro slime-defstate (name variables doc &rest events) "Define a state called NAME and comprised of VARIABLES. DOC is a documentation string. @@ -748,22 +777,7 @@ ,doc (slime-make-state ',name ,(slime-make-state-function variables events)))) -(defun slime-make-state-function (arglist clauses) - "Build the function that implements a state. -The state's variables are moved into lexical bindings." - (let ((event-var (gensym "event-"))) - `(lexical-let ,(mapcar* #'list arglist arglist) - (lambda (,event-var) - (destructure-case ,event-var - , at clauses - ;; Every state can handle the event (activate). By default - ;; it does nothing. - ,@(if (member* '(activate) clauses :key #'car :test #'equal) - '() - '( ((activate) nil)) ) - (t (error "Can't handle event %S in state %S" - ,event-var - (slime-state-name (slime-current-state))))))))) + ;;;;; The SLIME state machine definition @@ -1140,7 +1154,7 @@ (defun slime-forward-source-path (source-path) (let ((origin (point))) (cond ((null source-path) - (or (ignore-errors (slime-forward-sexp) (backward-sexp) t) + (or (ignore-errors (down-list 1) (backward-char 1) t) (goto-char origin))) (t (or (ignore-errors (down-list 1) @@ -1434,7 +1448,8 @@ (let ((minibuffer-setup-hook (cons (lexical-let ((package (slime-buffer-package))) (lambda () - (setq slime-buffer-package package))) + (setq slime-buffer-package package) + (set-syntax-table lisp-mode-syntax-table))) minibuffer-setup-hook))) (read-from-minibuffer prompt initial-value slime-read-expression-map nil 'slime-read-expression-history))) @@ -1520,10 +1535,11 @@ (cond ((null source-location) (message "No definition found: %s" name)) ((eq (car source-location) :error) - (message (cadr source-location))) + (slime-message "%s" (cadr source-location))) (t (slime-goto-source-location source-location) - (ring-insert-at-beginning slime-find-definition-history-ring origin))))) + (ring-insert-at-beginning + slime-find-definition-history-ring origin))))) ;;; Interactive evaluation. @@ -1537,7 +1553,6 @@ (slime-show-evaluation-result-continuation))) (defun slime-display-buffer-region (buffer start end &optional border) - (slime-save-window-configuration) (let ((border (or border 0))) (with-current-buffer buffer (save-selected-window @@ -1553,13 +1568,15 @@ ;; (set-window-start sets a "modified" flag, but only if the ;; window is not selected.) (set-window-start win (point)) - (let* ((lines (max (count-screen-lines (point) end) 1)) - (new-height (1+ (min (/ (frame-height) 2) - (+ border lines)))) - (diff (- new-height (window-height win)))) - (let ((window-min-height 1)) - (select-window win) - (enlarge-window diff))))))))) + ;; don't resize vertically split windows + (when (= (window-width) (frame-width)) + (let* ((lines (max (count-screen-lines (point) end) 1)) + (new-height (1+ (min (/ (frame-height) 2) + (+ border lines)))) + (diff (- new-height (window-height win)))) + (let ((window-min-height 1)) + (select-window win) + (enlarge-window diff)))))))))) (defun slime-show-evaluation-result (output-start value) (message "=> %s" value) @@ -1621,7 +1638,11 @@ (slime-eval-describe `(swank:disassemble-symbol ,symbol-name))) (defun slime-load-file (filename) - (interactive "fLoad file: ") + (interactive (list + (read-file-name "Load file: " nil nil + nil (file-name-sans-extension + (file-name-nondirectory + (buffer-file-name)))))) (slime-eval-async `(swank:load-file ,(expand-file-name filename)) nil (slime-show-evaluation-result-continuation))) @@ -1663,12 +1684,13 @@ (let ((pkg (slime-read-package-name "Package: "))) (if (string= pkg "") nil pkg))) (list (read-string "SLIME Apropos: ") t nil))) - (slime-eval-async - `(swank:apropos-list-for-emacs ,string ,only-external-p ,package) - (slime-buffer-package t) - (lexical-let ((string string) - (package package)) - (lambda (r) (slime-show-apropos r string package))))) + (let ((buffer-package (slime-buffer-package t))) + (slime-eval-async + `(swank:apropos-list-for-emacs ,string ,only-external-p ,package) + buffer-package + (lexical-let ((string string) + (package (or package buffer-package))) + (lambda (r) (slime-show-apropos r string package)))))) (defun slime-apropos-all () "Shortcut for (slime-apropos nil nil)" @@ -1694,6 +1716,7 @@ (princ string) (add-text-properties start (point) props)))) +(eval-when (compile) (require 'apropos)) (autoload 'apropos-mode "apropos") (defvar apropos-label-properties) @@ -1793,7 +1816,7 @@ (defun slime-show-xrefs (file-referrers type symbol package) "Show the results of an XREF query." (if (null file-referrers) - (message "No references found.") + (message "No references found for %s." symbol) (slime-save-window-configuration) (setq slime-next-location-function 'slime-goto-next-xref) (with-current-buffer (slime-xref-buffer t) @@ -1826,7 +1849,7 @@ 'font-lock-function-name-face 'font-lock-comment-face)) (format "%s\n" referrer))))) - + ;;;;; XREF results buffer and window management @@ -1897,6 +1920,123 @@ (error "No context for finding locations.")) (funcall slime-next-location-function)) + +;;; + +(defun slime-list-callers (symbol-name) + (interactive (list (slime-read-symbol-name "List callers: "))) + (slime-eval-select-function-list `(swank:list-callers ,symbol-name))) + +(defun slime-list-callees (symbol-name) + (interactive (list (slime-read-symbol-name "List callees: "))) + (slime-eval-select-function-list `(swank:list-callees ,symbol-name))) + +(defun slime-eval-select-function-list (sexp) + (lexical-let ((package (slime-buffer-package))) + (slime-eval-async sexp package + (lambda (names) + (slime-select-function names package))) + (slime-save-window-configuration))) + +(defun slime-select-function (function-names package) + (cond ((null function-names) + (message "No callers")) + (t + (lexical-let ((function-names function-names) + (package package)) + (slime-select function-names + (lambda (index) + (slime-eval-async + `(swank:function-source-location-for-emacs + ,(nth index function-names)) + package + #'slime-carefully-show-source-location)) + (lambda (index))))))) + +(defun slime-carefully-show-source-location (location) + (condition-case e + (slime-show-source-location location) + (error (message "%s" (error-message-string e)) + (ding)))) + +(defun slime-get-select-window (labels) + (split-window (selected-window) + (- (frame-width) + (min (1+ (max + (loop for l in labels maximize (length l)) + window-min-width)) + 25)) + t)) + +(defun slime-select (labels follow finish) + "Select an item form the list LABELS. + +The list is displayed in a new buffer. FOLLOW is called with the +current index whenever a new line is selected. FINISH is called with +the current index when the selection is completed." + (set-buffer (get-buffer-create "*SLIME Select*")) + (setq buffer-read-only nil) + (erase-buffer) + (loop for (label . r) on labels + do (progn (insert label) + (when r (insert "\n")))) + (goto-char (point-min)) + (slime-select-mode) + (setq slime-select-follow follow) + (setq slime-select-finish finish) + (setq buffer-read-only t) + (setq slime-select-saved-window-configuration + (current-window-configuration)) + (let ((window (slime-get-select-window labels))) + (set-window-buffer window (current-buffer)) + (select-window window) + (slime-select-post-command-hook))) + +(defvar slime-select-mode-map) +(defvar slime-previous-selected-line) + +(defun slime-selected-line () + (count-lines (point-min) (save-excursion (beginning-of-line) (point)))) + +(define-derived-mode slime-select-mode fundamental-mode "SLIME-Select" + "Mode to select an item from a list." + (mapc #'make-variable-buffer-local + '(slime-previous-selected-line + slime-select-follow + slime-select-finish + slime-select-saved-window-configuration)) + (setq slime-previous-selected-line -1) + (make-local-hook 'post-command-hook) + (add-hook 'post-command-hook 'slime-select-post-command-hook nil t) + (add-hook (make-local-variable 'kill-buffer-hook) 'sldb-delete-overlays) + (slime-mode t)) + +(defun slime-select-post-command-hook () + (unless (eq slime-previous-selected-line (slime-selected-line)) + (let ((line (slime-selected-line))) + (setq slime-previous-selected-line line) + (ignore-errors (funcall slime-select-follow line))))) + +(defun slime-select-done () + (interactive) + (save-current-buffer + (funcall slime-select-finish (slime-selected-line))) + (slime-select-cleanup)) + +(defun slime-select-cleanup () + (let ((buffer (current-buffer))) + (delete-windows-on buffer) + (kill-buffer buffer))) + +(defun slime-select-quit () + (interactive) + (set-window-configuration slime-select-saved-window-configuration) + (slime-select-cleanup)) + +(slime-define-keys slime-select-mode-map + ([return] 'slime-select-done) + ("q" 'slime-select-quit)) + ;;; Macroexpansion @@ -1991,10 +2131,14 @@ (pop-to-buffer (current-buffer)) (run-hooks 'sldb-hook))) +(defmacro sldb-propertize-region (props &rest body) + (let ((start (gensym))) + `(let ((,start (point))) + (prog1 (progn , at body) + (add-text-properties ,start (point) ,props))))) + (defun slime-insert-propertized (props &rest args) - (let ((start (point))) - (apply #'insert args) - (add-text-properties start (point) props))) + (sldb-propertize-region props (apply #'insert args))) (define-derived-mode sldb-mode fundamental-mode "sldb" "Superior lisp debugger mode @@ -2019,23 +2163,26 @@ (cond ((= sldb-backtrace-length (1+ number))) (t (slime-insert-propertized - '(sldb-default-action + `(sldb-default-action sldb-fetch-more-frames - point-entered sldb-fetch-more-frames) - " --more--")))))) + point-entered sldb-fetch-more-frames + sldb-previous-frame-number ,number) + " --more--\n")))))) (defun sldb-fetch-more-frames (&optional start end) (let ((inhibit-point-motion-hooks t)) - (let ((previous (sldb-previous-frame-number))) - (let ((inhibit-read-only t)) - (beginning-of-line) - (let ((start (point))) - (end-of-buffer) - (delete-region start (point))) - (sldb-insert-frames - (slime-eval `(swank:backtrace-for-emacs - ,(1+ previous) - ,(+ previous 40)))))))) + (let ((inhibit-read-only t)) + (let ((previous (get-text-property (point) + 'sldb-previous-frame-number))) + (when previous + (beginning-of-line) + (let ((start (point))) + (end-of-buffer) + (delete-region start (point))) + (sldb-insert-frames + (slime-eval `(swank:backtrace-for-emacs + ,(1+ previous) + ,(+ previous 40))))))))) (defun sldb-default-action/mouse (event) (interactive "e") @@ -2110,9 +2257,12 @@ (let* ((number (sldb-frame-number-at-point)) (source-location (slime-eval `(swank:frame-source-location-for-emacs ,number)))) - (save-selected-window - (slime-goto-source-location source-location t) - (sldb-highlight-sexp)))) + (slime-show-source-location source-location))) + +(defun slime-show-source-location (source-location) + (save-selected-window + (slime-goto-source-location source-location t) + (sldb-highlight-sexp))) (defun sldb-frame-details-visible-p () (and (get-text-property (point) 'frame) @@ -2126,12 +2276,6 @@ (sldb-show-frame-details) (sldb-hide-frame-details)))) -(defmacro* sldb-propertize-region (props &body body) - (let ((start (gensym))) - `(let ((,start (point))) - (prog1 (progn , at body) - (add-text-properties ,start (point) ,props))))) - (put 'sldb-propertize-region 'lisp-indent-function 1) (defun sldb-frame-region () @@ -2191,9 +2335,17 @@ (interactive (list (slime-read-from-minibuffer "Eval in frame: "))) (let* ((number (sldb-frame-number-at-point))) (slime-eval-async `(swank:eval-string-in-frame ,string ,number) - nil + (slime-buffer-package) (lambda (reply) (slime-message "==> %s" reply))))) +(defun sldb-pprint-eval-in-frame (string) + (interactive (list (slime-read-from-minibuffer "Eval in frame: "))) + (let* ((number (sldb-frame-number-at-point))) + (slime-eval-async `(swank:eval-string-in-frame ,string ,number) + nil + (lambda (result) + (slime-show-description result nil))))) + (defun sldb-forward-frame () (goto-char (next-single-char-property-change (point) 'frame))) @@ -2284,17 +2436,12 @@ (defun sldb-restart-at-point () (get-text-property (point) 'restart-number)) -(defmacro slime-define-keys (keymap &rest key-command) - `(progn . ,(mapcar (lambda (k-c) `(define-key ,keymap . ,k-c)) - key-command))) - -(put 'slime-define-keys 'lisp-indent-function 1) - (slime-define-keys sldb-mode-map ("v" 'sldb-show-source) ((kbd "RET") 'sldb-default-action) ([mouse-2] 'sldb-default-action/mouse) ("e" 'sldb-eval-in-frame) + ("p" 'sldb-pprint-eval-in-frame) ("d" 'sldb-down) ("u" 'sldb-up) ("\M-n" 'sldb-details-down) @@ -2326,7 +2473,97 @@ ,(number-to-string n))))) (define-sldb-invoke-restart-keys 0 9) + + +;;; Inspector + +(defvar slime-inspector-mark-stack '()) + +(defun slime-inspect (string) + (interactive + (list (slime-read-from-minibuffer "Inspect value (evaluated): " + (slime-last-expression)))) + (slime-eval-async `(swank:init-inspector ,string) (slime-buffer-package) + 'slime-open-inspector)) + +(define-derived-mode slime-inspector-mode fundamental-mode "Slime-Inspector" + (set-syntax-table lisp-mode-syntax-table) + (set (make-local-variable 'truncate-lines) t) + (slime-mode t) + (setq buffer-read-only t)) + +(defun slime-inspector-buffer () + (or (get-buffer "*Slime Inspector*") + (with-current-buffer (get-buffer-create "*Slime Inspector*") + (setq slime-inspector-mark-stack '()) + (slime-inspector-mode) + (current-buffer)))) + +(defun slime-open-inspector (inspected-parts &optional point) + (with-current-buffer (slime-inspector-buffer) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (getf inspected-parts :text)) + (while (eq (char-before) ?\n) (backward-delete-char 1)) + (insert "\n" + " [type: " (getf inspected-parts :type) "]\n" + " " (getf inspected-parts :primitive-type) "\n" + "\n" + "Slots:\n") + (save-excursion + (loop for (label . value) in (getf inspected-parts :parts) + for i from 0 + do (sldb-propertize-region `(slime-part-number ,i) + (insert label ": " value "\n")))) + (pop-to-buffer (current-buffer)) + (when point (goto-char point))))) + +(defun slime-inspector-object-at-point () + (or (get-text-property (point) 'slime-part-number) + (error "No part at point"))) + +(defun slime-inspector-inspect-object-at-point (number) + (interactive (list (slime-inspector-object-at-point))) + (slime-eval-async `(swank:inspect-nth-part ,number) nil + 'slime-open-inspector) + (push (point) slime-inspector-mark-stack)) + +(defun slime-inspector-pop () + (interactive) + (slime-eval-async + `(swank:inspector-pop) nil + (lambda (result) + (cond (result + (slime-open-inspector result (pop slime-inspector-mark-stack))) + (t + (message "No previous object") + (ding)))))) + +(defun slime-inspector-next () + (interactive) + (let ((result (slime-eval `(swank:inspector-next) nil))) + (cond (result + (push (point) slime-inspector-mark-stack) + (slime-open-inspector result)) + (t (message "No next object") + (ding))))) +(defun slime-inspector-quit () + (interactive) + (slime-eval-async `(swank:quit-inspector) nil (lambda (_))) + (kill-buffer (current-buffer))) + +(defun slime-inspector-describe () + (interactive) + (slime-eval-describe `(swank:describe-inspectee))) + +(slime-define-keys slime-inspector-mode-map + ([return] 'slime-inspector-inspect-object-at-point) + ("l" 'slime-inspector-pop) + ("n" 'slime-inspector-next) + ("d" 'slime-inspector-describe) + ("q" 'slime-inspector-quit)) + ;;; Test suite @@ -2570,6 +2807,8 @@ #| #||# #||# |# (:bar))" + (:bar)) + ("(defun :foo () (list `(1 ,(random 10) 2 ,@(random 10) 3 ,(:bar))))" (:bar)) ) (with-temp-buffer From heller at common-lisp.net Wed Oct 15 17:47:39 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 15 Oct 2003 13:47:39 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv27991 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Oct 15 13:47:39 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.28 slime/ChangeLog:1.29 --- slime/ChangeLog:1.28 Wed Oct 15 12:57:22 2003 +++ slime/ChangeLog Wed Oct 15 13:47:38 2003 @@ -1,3 +1,12 @@ +2003-10-15 Helmut Eller + + * slime.el: Inspector support. list-callers, list-callees + implemented without xref. + + * swank.lisp: Lisp side for inspector and list-callers, + list-calees. Better fdefinition finding for struct-accessors. + + 2003-10-15 Luke Gorrie * slime.el (slime-point-moves-p): Macro for executing subforms and From dbarlow at common-lisp.net Wed Oct 15 22:02:50 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Wed, 15 Oct 2003 18:02:50 -0400 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp slime/swank-openmcl.lisp slime/swank-sbcl.lisp slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23193 Modified Files: swank-cmucl.lisp swank-openmcl.lisp swank-sbcl.lisp swank.lisp Log Message: Second iteration refactoring common bits: server-port *swank-debug-p* start-server *emacs-io* *slime-output* read-next-form read-form *redirect-output* read-from-emacs send-to-emacs prin1-to-string-for-emacs defslimefun *buffer-package* from-string to-string guess-package-from-string eval-string interactive-eval defslimefun-unimplemented *swank-io-package* Date: Wed Oct 15 18:02:50 2003 Author: dbarlow Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.1 slime/swank-cmucl.lisp:1.2 --- slime/swank-cmucl.lisp:1.1 Wed Oct 15 17:24:33 2003 +++ slime/swank-cmucl.lisp Wed Oct 15 18:02:49 2003 @@ -3,20 +3,8 @@ (in-package :swank) -(defconstant server-port 4005 - "Default port for the swank TCP server.") - -(defvar *swank-debug-p* t - "When true extra debug printouts are enabled.") - ;;; Setup and hooks. -(defun start-server (&optional (port server-port)) - (create-swank-server port :reuse-address t) - (setf c:*record-xref-info* t) - (when *swank-debug-p* - (format *debug-io* "~&;; Swank ready.~%"))) - (defun set-fd-non-blocking (fd) (flet ((fcntl (fd cmd arg) (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg) @@ -29,9 +17,6 @@ ;;; TCP Server. -(defvar *emacs-io* nil - "Bound to a TCP stream to Emacs during request processing.") - (defstruct (slime-output-stream (:include lisp::string-output-stream (lisp::misc #'slime-out-misc))) @@ -57,9 +42,6 @@ (return count)))) (t (lisp::string-out-misc stream operation arg1 arg2)))) -(defvar *slime-output* nil - "Bound to a slime-output-stream during request processing.") - (defun create-swank-server (port &key reuse-address (address "localhost")) "Create a SWANK TCP server." (let* ((hostent (ext:lookup-host-entry address)) @@ -100,79 +82,6 @@ (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*)) (close *emacs-io*))))) -(defun read-next-form () - (handler-case - (let* ((length (logior (ash (read-byte *emacs-io*) 16) - (ash (read-byte *emacs-io*) 8) - (read-byte *emacs-io*))) - (string (make-string length))) - (sys:read-n-bytes *emacs-io* string 0 length) - (read-form string)) - (condition (c) - (throw 'serve-request-catcher c)))) - -(defun read-form (string) - (with-standard-io-syntax - (let ((*package* *swank-io-package*)) - (read-from-string string)))) - -(defparameter *redirect-output* t) - -(defun read-from-emacs () - "Read and process a request from Emacs." - (let ((form (read-next-form))) - (if *redirect-output* - (let ((*standard-output* *slime-output*) - (*error-output* *slime-output*) - (*trace-output* *slime-output*) - (*debug-io* *slime-output*) - (*query-io* *slime-output*)) - (apply #'funcall form)) - (apply #'funcall form)))) - -(defun send-to-emacs (object) - "Send OBJECT to Emacs." - (let* ((string (prin1-to-string-for-emacs object)) - (length (1+ (length string)))) - (loop for position from 16 downto 0 by 8 - do (write-byte (ldb (byte 8 position) length) *emacs-io*)) - (write-string string *emacs-io*) - (terpri *emacs-io*) - (force-output *emacs-io*))) - -(defun prin1-to-string-for-emacs (object) - (with-standard-io-syntax - (let ((*print-case* :downcase) - (*print-readably* t) - (*print-pretty* nil) - (*package* *swank-io-package*)) - (prin1-to-string object)))) - -;;; Functions for Emacs to call. - -(defmacro defslimefun (fun &rest rest) - `(progn - (defun ,fun , at rest) - (export ',fun :swank))) - -;;; Utilities. - -(defvar *buffer-package*) -(setf (documentation '*buffer-package* 'symbol) - "Package corresponding to slime-buffer-package. - -EVAL-STRING binds *buffer-package*. Strings originating from a slime -buffer are best read in this package. See also FROM-STRING and TO-STRING.") - -(defun from-string (string) - "Read string in the *BUFFER-PACKAGE*" - (let ((*package* *buffer-package*)) - (read-from-string string))) - -(defun to-string (string) - "Write string in the *BUFFER-PACKAGE*" - (let ((*package* *buffer-package*)) - (prin1-to-string string))) (defun read-symbol/package (symbol-name package-name) (let ((package (find-package package-name))) @@ -184,12 +93,6 @@ ;;; Asynchronous eval -(defun guess-package-from-string (name) - (or (and name - (or (find-package name) - (find-package (string-upcase name)))) - *package*)) - (defvar *swank-debugger-condition*) (defvar *swank-debugger-hook*) @@ -198,23 +101,6 @@ (*swank-debugger-hook* hook)) (sldb-loop))) -(defslimefun eval-string (string buffer-package) - (let ((*debugger-hook* #'swank-debugger-hook)) - (let (ok result) - (unwind-protect - (let ((*buffer-package* (guess-package-from-string buffer-package))) - (assert (packagep *buffer-package*)) - (setq result (eval (read-form string))) - (force-output) - (setq ok t)) - (send-to-emacs (if ok `(:ok ,result) '(:aborted))))))) - -(defslimefun interactive-eval (string) - (let ((*package* *buffer-package*)) - (let ((values (multiple-value-list (eval (read-from-string string))))) - (force-output) - (format nil "~{~S~^, ~}" values)))) - (defslimefun interactive-eval-region (string) (let ((*package* *buffer-package*)) (with-input-from-string (stream string) Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.2 slime/swank-openmcl.lisp:1.3 --- slime/swank-openmcl.lisp:1.2 Wed Oct 15 17:24:33 2003 +++ slime/swank-openmcl.lisp Wed Oct 15 18:02:49 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.2 2003/10/15 21:24:33 dbarlow Exp $ +;;; $Id: swank-openmcl.lisp,v 1.3 2003/10/15 22:02:49 dbarlow Exp $ ;;; ;;; @@ -46,33 +46,13 @@ ;;; run correctly (it hangs upon entering the debugger). ;;; -;;; Administrivia - (in-package :swank) -(defconstant server-port 4005 - "Default port for the Swank TCP server.") - -(defvar *swank-debug-p* t - "When true, print extra debugging information.") - -;;; Setup and Hooks - -(defun start-server (&optional (port server-port)) - "Start the Slime backend on TCP port `port'." - (create-swank-server port :reuse-address t)) - ;;; TCP Server ;; In OpenMCL, the Swank backend runs in a separate thread and simply ;; blocks on its TCP port while waiting for forms to evaluate. -(defvar *emacs-io* nil - "Bound to a TCP stream to Emacs during request processing.") - -(defvar *slime-output* nil - "Bound to a slime-output-stream during request processing.") - (defun create-swank-server (port &key reuse-address) "Create a Swank TCP server on `port'." (ccl:process-run-function "Swank Request Processor" #'swank-main-loop @@ -112,53 +92,6 @@ (format *terminal-io* "~&;; Swank: Closed connection: ~A~%" *emacs-io*) (close *emacs-io*))) -(defun read-from-emacs () - "Read and process a request from Emacs." - (let ((form (read-next-form))) - (let ((*standard-output* *slime-output*) - (*error-output* *slime-output*) - (*trace-output* *slime-output*) - (*debug-io* *slime-output*) - (*query-io* *slime-output*)) - (apply #'funcall form)))) - -(defun read-next-form () - "Read the next Slime request from *EMACS-IO* and return an -S-expression to be evaulated to handle the request. If an error -occurs during parsing, it will be noted and control will be tranferred -back to the main request handling loop." - (handler-case - (let* ((length (logior (ash (read-byte *emacs-io*) 16) - (ash (read-byte *emacs-io*) 8) - (read-byte *emacs-io*))) - (string (make-string length))) - (read-sequence string *emacs-io*) - (read-form string)) - (condition (c) - (throw 'serve-request-catcher c)))) - -(defun read-form (string) - (with-standard-io-syntax - (let ((*package* *swank-io-package*)) - (read-from-string string)))) - -(defun send-to-emacs (object) - "Send `object' to Emacs." - (let* ((string (prin1-to-string-for-emacs object)) - (length (1+ (length string)))) - (loop for position from 16 downto 0 by 8 - do (write-byte (ldb (byte 8 position) length) *emacs-io*)) - (write-string string *emacs-io*) - (terpri *emacs-io*) - (force-output *emacs-io*))) - -(defun prin1-to-string-for-emacs (object) - (let ((*print-case* :downcase) - (*print-readably* nil) - (*print-pretty* nil) - (*package* *swank-io-package*)) - (prin1-to-string object))) - ;;; Redirecting Output to Emacs ;; This buffering is done via a Gray stream instead of the CMU-specific @@ -178,32 +111,6 @@ (slime-output-stream-buffer stream)))) (setf (slime-output-stream-buffer stream) (make-string-output-stream))) -;;; Utilities - -(defvar *buffer-package*) - -(defun from-string (string) - "Read string in the *BUFFER-PACKAGE*" - (let ((*package* *buffer-package*)) - (read-from-string string))) - -(defun to-string (string) - "Write string in the *BUFFER-PACKAGE*." - (let ((*package* *buffer-package*)) - (prin1-to-string string))) - -(defmacro defslimefun (fun &rest rest) - `(progn - (defun ,fun , at rest) - (export ',fun :swank))) - -(defmacro defslimefun-unimplemented (fun args) - `(progn - (defun ,fun ,args - (declare (ignore , at args)) - (error "Backend function ~A not implemented." ',fun)) - (export ',fun :swank))) - ;;; Evaluation (defvar *swank-debugger-condition*) @@ -219,28 +126,6 @@ (let ((*swank-debugger-condition* condition) (*swank-debugger-hook* hook)) (sldb-loop))) - -(defun guess-package-from-string (name) - (or (and name - (or (find-package name) - (find-package (string-upcase name)))) - *package*)) - -(defslimefun eval-string (string buffer-package) - (let ((*debugger-hook* #'swank-debugger-hook)) - (let (ok result) - (unwind-protect - (let ((*buffer-package* (guess-package-from-string buffer-package))) - (assert (packagep *buffer-package*)) - (setq result (eval (read-form string))) - (force-output) - (setq ok t)) - (send-to-emacs (if ok `(:ok ,result) '(:aborted))))))) - -(defslimefun interactive-eval (string) - (let ((values (multiple-value-list (eval (from-string string))))) - (force-output) - (format nil "~{~S~^, ~}" values))) (defslimefun-unimplemented interactive-eval-region (string)) (defslimefun-unimplemented pprint-eval (string)) Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.2 slime/swank-sbcl.lisp:1.3 --- slime/swank-sbcl.lisp:1.2 Wed Oct 15 17:24:33 2003 +++ slime/swank-sbcl.lisp Wed Oct 15 18:02:49 2003 @@ -48,29 +48,11 @@ (declaim (optimize (debug 3))) (in-package :swank) -(defconstant server-port 4005 - "Default port for the Swank TCP server.") - -(defvar *swank-debug-p* t - "When true, print extra debugging information.") - -;;; Setup and Hooks - -(defun start-server (&optional (port server-port)) - "Start the Slime backend on TCP port `port'." - (create-swank-server port :reuse-address t)) - ;;; TCP Server ;; The Swank backend runs in a separate thread and simply blocks on ;; its TCP port while waiting for forms to evaluate. -(defvar *emacs-io* nil - "Bound to a TCP stream to Emacs during request processing.") - -(defvar *slime-output* nil - "Bound to a slime-output-stream during request processing.") - (defun create-swank-server (port &key reuse-address) "Create a Swank TCP server on `port'." (sb-thread:make-thread @@ -128,62 +110,6 @@ (format *terminal-io* "~&;; Swank: Closed connection: ~A~%" *emacs-io*) (close *emacs-io*))) -(defun read-from-emacs () - "Read and process a request from Emacs." - (let ((form (read-next-form))) - (let ((*standard-output* *slime-output*) - (*error-output* *slime-output*) - (*trace-output* *slime-output*) - (*debug-io* *slime-output*) - (*query-io* *slime-output*)) - (apply #'funcall form)))) - -(defun read-next-form () - "Read the next Slime request from *EMACS-IO* and return an -S-expression to be evaulated to handle the request. If an error -occurs during parsing, it will be noted and control will be tranferred -back to the main request handling loop." - (handler-case - (let* ((length (logior (ash (read-byte *emacs-io*) 16) - (ash (read-byte *emacs-io*) 8) - (read-byte *emacs-io*))) - (string (make-string length))) - (read-sequence string *emacs-io*) - (read-form string)) - (condition (c) - (throw 'serve-request-catcher c)))) - -(defvar *swank-io-package* - (let ((package (make-package "SWANK-IO-PACKAGE"))) - ;; my suspicion is that this package is not intended to use any other - ;; at all, hence the import of NIL. However, make-package with no - ;; :use option (as was here) in CMUCL defaults to using the CL package - ;; and there are other symbols (most notably QUOTE) which swank needs - (import '(nil t quote) package) - package)) - -(defun read-form (string) - (with-standard-io-syntax - (let ((*package* *swank-io-package*)) - (read-from-string string)))) - -(defun send-to-emacs (object) - "Send `object' to Emacs." - (let* ((string (prin1-to-string-for-emacs object)) - (length (1+ (length string)))) - (loop for position from 16 downto 0 by 8 - do (write-byte (ldb (byte 8 position) length) *emacs-io*)) - (write-string string *emacs-io*) - (terpri *emacs-io*) - (force-output *emacs-io*))) - -(defun prin1-to-string-for-emacs (object) - (let ((*print-case* :downcase) - (*print-readably* nil) - (*print-pretty* nil) - (*package* *swank-io-package*)) - (prin1-to-string object))) - ;;; Redirecting Output to Emacs ;; This buffering is done via a Gray stream instead of the CMU-specific @@ -205,32 +131,6 @@ ;;; Utilities -(defvar *buffer-package*) - -(defun from-string (string) - "Read string in the *BUFFER-PACKAGE*" - (let ((*package* *buffer-package*)) - (read-from-string string))) - -(defun to-string (string) - "Write string in the *BUFFER-PACKAGE*." - (let ((*package* *buffer-package*)) - (prin1-to-string string))) - -(defmacro defslimefun (fun &rest rest) - `(progn - (defun ,fun , at rest) - (export ',fun :swank))) - -(defmacro defslimefun-unimplemented (fun args) - `(progn - (defun ,fun ,args - (declare (ignore , at args)) - (error "Backend function ~A not implemented." ',fun)) - (export ',fun :swank))) - - - (defvar *swank-debugger-condition*) (defvar *swank-debugger-hook*) (defvar *swank-debugger-stack-frame*) @@ -239,32 +139,7 @@ (let ((*swank-debugger-condition* condition) (*swank-debugger-hook* hook)) (sldb-loop))) - -(defun guess-package-from-string (name) - (or (and name - (or (find-package name) - (find-package (string-upcase name)))) - *package*)) - -;;; common to all backends -(defslimefun eval-string (string buffer-package) - (let ((*debugger-hook* #'swank-debugger-hook)) - (let (ok result) - (unwind-protect - (let ((*buffer-package* (guess-package-from-string buffer-package))) - (assert (packagep *buffer-package*)) - (setq result (eval (read-form string))) - (force-output) - (setq ok t)) - (send-to-emacs (if ok `(:ok ,result) '(:aborted))))))) - -;;; following five functions from cmucl -(defslimefun interactive-eval (string) - (let ((*package* *buffer-package*)) - (let ((values (multiple-value-list (eval (read-from-string string))))) - (force-output) - (format nil "~{~S~^, ~}" values)))) - + (defslimefun interactive-eval-region (string) (let ((*package* *buffer-package*)) (with-input-from-string (stream string) Index: slime/swank.lisp diff -u slime/swank.lisp:1.27 slime/swank.lisp:1.28 --- slime/swank.lisp:1.27 Wed Oct 15 17:24:33 2003 +++ slime/swank.lisp Wed Oct 15 18:02:49 2003 @@ -10,6 +10,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defpackage :swank (:use :common-lisp) + (:nicknames "SWANK-IMPL") (:export #:start-server))) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -27,6 +28,141 @@ package)) (declaim (optimize (debug 3))) + +(defconstant server-port 4005 + "Default port for the Swank TCP server.") + +(defvar *swank-debug-p* t + "When true, print extra debugging information.") + +;;; Setup and Hooks + +(defun start-server (&optional (port server-port)) + "Start the Slime backend on TCP port `port'." + (swank-impl:create-swank-server port :reuse-address t) + #+xref (setf c:*record-xref-info* t) + (when *swank-debug-p* + (format *debug-io* "~&;; Swank ready.~%"))) + +;;; IO to emacs + +(defvar *emacs-io* nil + "Bound to a TCP stream to Emacs during request processing.") + +(defvar *slime-output* nil + "Bound to a slime-output-stream during request processing.") + +(defparameter *redirect-output* t) + +(defun read-from-emacs () + "Read and process a request from Emacs." + (let ((form (read-next-form))) + (if *redirect-output* + (let ((*standard-output* *slime-output*) + (*error-output* *slime-output*) + (*trace-output* *slime-output*) + (*debug-io* *slime-output*) + (*query-io* *slime-output*)) + (apply #'funcall form)) + (apply #'funcall form)))) + +(defun read-next-form () + "Read the next Slime request from *EMACS-IO* and return an +S-expression to be evaulated to handle the request. If an error +occurs during parsing, it will be noted and control will be tranferred +back to the main request handling loop." + (handler-case + (let* ((length (logior (ash (read-byte *emacs-io*) 16) + (ash (read-byte *emacs-io*) 8) + (read-byte *emacs-io*))) + (string (make-string length))) + (read-sequence string *emacs-io*) + (read-form string)) + (condition (c) + (throw 'serve-request-catcher c)))) + +(defun read-form (string) + (with-standard-io-syntax + (let ((*package* *swank-io-package*)) + (read-from-string string)))) + +(defun send-to-emacs (object) + "Send `object' to Emacs." + (let* ((string (prin1-to-string-for-emacs object)) + (length (1+ (length string)))) + (loop for position from 16 downto 0 by 8 + do (write-byte (ldb (byte 8 position) length) *emacs-io*)) + (write-string string *emacs-io*) + (terpri *emacs-io*) + (force-output *emacs-io*))) + +(defun prin1-to-string-for-emacs (object) + (let ((*print-case* :downcase) + (*print-readably* nil) + (*print-pretty* nil) + (*package* *swank-io-package*)) + (prin1-to-string object))) + +;;; The Reader + +(defvar *buffer-package*) +(setf (documentation '*buffer-package* 'symbol) + "Package corresponding to slime-buffer-package. + +EVAL-STRING binds *buffer-package*. Strings originating from a slime +buffer are best read in this package. See also FROM-STRING and TO-STRING.") + + +(defun from-string (string) + "Read string in the *BUFFER-PACKAGE*" + (let ((*package* *buffer-package*)) + (read-from-string string))) + +(defun to-string (string) + "Write string in the *BUFFER-PACKAGE*." + (let ((*package* *buffer-package*)) + (prin1-to-string string))) + +(defun guess-package-from-string (name) + (or (and name + (or (find-package name) + (find-package (string-upcase name)))) + *package*)) + + +;;; public interface. slimefuns are the things that emacs is allowed +;;; to call + +(defmacro defslimefun (fun &rest rest) + `(progn + (defun ,fun , at rest) + (export ',fun :swank))) + +(defmacro defslimefun-unimplemented (fun args) + `(progn + (defun ,fun ,args + (declare (ignore , at args)) + (error "Backend function ~A not implemented." ',fun)) + (export ',fun :swank))) + +(defslimefun eval-string (string buffer-package) + (let ((*debugger-hook* #'swank-debugger-hook)) + (let (ok result) + (unwind-protect + (let ((*buffer-package* (guess-package-from-string buffer-package))) + (assert (packagep *buffer-package*)) + (setq result (eval (read-form string))) + (force-output) + (setq ok t)) + (send-to-emacs (if ok `(:ok ,result) '(:aborted))))))) + +(defslimefun interactive-eval (string) + (let ((values (multiple-value-list (eval (from-string string))))) + (force-output) + (format nil "~{~S~^, ~}" values))) + + + (eval-when (:compile-toplevel) (compile-file swank::*sysdep-pathname*)) (eval-when (:load-toplevel :execute) (load swank::*sysdep-pathname*)) From dbarlow at common-lisp.net Wed Oct 15 22:48:31 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Wed, 15 Oct 2003 18:48:31 -0400 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp slime/swank-openmcl.lisp slime/swank-sbcl.lisp slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18257 Modified Files: swank-cmucl.lisp swank-openmcl.lisp swank-sbcl.lisp swank.lisp Log Message: Third portablizing iteration: more refactoring common bits pprint-eval set-package *compiler-notes* clear-compiler-notes *notes-database* clear-note-database features canonicalize-filename compiler-notes-for-file compiler-notes-for-emacs measure-time-interval call-with-compilation-hooks list-all-package-names apropos-symbols print-output-to-string print-description-to-string describe-symbol describe-function apply-macro-expander swank-macroexpand-1 swank-macroexpand disassemble-symbol Date: Wed Oct 15 18:48:31 2003 Author: dbarlow Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.2 slime/swank-cmucl.lisp:1.3 --- slime/swank-cmucl.lisp:1.2 Wed Oct 15 18:02:49 2003 +++ slime/swank-cmucl.lisp Wed Oct 15 18:48:30 2003 @@ -110,17 +110,6 @@ do (force-output) finally (return (format nil "~{~S~^, ~}" result)))))) -(defslimefun pprint-eval (string) - (let ((*package* *buffer-package*)) - (let ((value (eval (read-from-string string)))) - (let ((*print-pretty* t) - (*print-circle* t) - (*print-level* nil) - (*print-length* nil) - (ext:*gc-verbose* nil)) - (with-output-to-string (stream) - (pprint value stream)))))) - (defslimefun re-evaluate-defvar (form) (let ((*package* *buffer-package*)) (let ((form (read-from-string form))) @@ -130,10 +119,6 @@ (makunbound name) (prin1-to-string (eval form)))))) -(defslimefun set-package (package) - (setq *package* (guess-package-from-string package)) - (package-name *package*)) - (defslimefun set-default-directory (directory) (setf (ext:default-directory) (namestring directory)) ;; Setting *default-pathname-defaults* to an absolute directory @@ -143,8 +128,7 @@ ;;;; Compilation Commands -(defvar *compiler-notes* '() - "List of compiler notes for the last compilation unit.") + (defvar *previous-compiler-condition* nil "Used to detect duplicates.") @@ -152,22 +136,6 @@ (defvar *previous-context* nil "Used for compiler warnings without context.") -(defvar *notes-database* (make-hash-table :test #'equal) - "Database of recorded compiler notes/warnings/erros (keyed by filename). -Each value is a list of (LOCATION SEVERITY MESSAGE CONTEXT) lists. - LOCATION is a position in the source code (integer or source path). - SEVERITY is one of :ERROR, :WARNING, and :NOTE. - MESSAGE is a string describing the note. - CONTEXT is a string giving further details of where the error occured.") - -(defun clear-compiler-notes () - (setf *compiler-notes* '()) - (setf *previous-compiler-condition* nil) - (setf *previous-context* nil)) - -(defun clear-note-database (filename) - (remhash (canonicalize-filename filename) *notes-database*)) - (defvar *buffername*) (defvar *buffer-offset*) @@ -243,46 +211,12 @@ (reverse (c::compiler-error-context-original-source-path context))))) -(defslimefun features () - (mapcar #'symbol-name *features*)) - -(defun canonicalize-filename (filename) - (namestring (unix:unix-resolve-links filename))) - -(defslimefun compiler-notes-for-file (filename) - "Return the compiler notes recorded for FILENAME. -\(See *NOTES-DATABASE* for a description of the return type.)" - (gethash (canonicalize-filename filename) *notes-database*)) - -(defslimefun compiler-notes-for-emacs () - "Return the list of compiler notes for the last compilation unit." - (reverse *compiler-notes*)) - -(defun measure-time-intervall (fn) - "Call FN and return the first return value and the elapsed time. -The time is measured in microseconds." - (multiple-value-bind (ok start-secs start-usecs) (unix:unix-gettimeofday) - (assert ok) - (let ((value (funcall fn))) - (multiple-value-bind (ok end-secs end-usecs) (unix:unix-gettimeofday) - (assert ok) - (values value (+ (* (- end-secs start-secs) 1000000) - (- end-usecs start-usecs))))))) - (defmacro with-trapping-compilation-notes (() &body body) `(handler-bind ((c::compiler-error #'handle-notification-condition) (c::style-warning #'handle-notification-condition) (c::warning #'handle-notification-condition)) , at body)) -(defun call-with-compilation-hooks (fn) - (multiple-value-bind (result usecs) - (with-trapping-compilation-notes () - (clear-compiler-notes) - (measure-time-intervall fn)) - (list (to-string result) - (format nil "~,2F" (/ usecs 1000000.0))))) - (defslimefun swank-compile-file (filename load) (call-with-compilation-hooks (lambda () @@ -555,14 +489,6 @@ (and (<= (length s1) (length s2)) (string-equal s1 s2 :end2 (length s1)))) -(defslimefun list-all-package-names () - (let ((list '())) - (maphash (lambda (name package) - (declare (ignore package)) - (pushnew name list)) - lisp::*package-names*) - list)) - ;;;; Definitions (defvar *debug-definition-finding* nil @@ -693,15 +619,6 @@ (let ((y (funcall f x))) (and y (list y))))) -(defun apropos-symbols (string &optional external-only package) - "Return the symbols matching an apropos search." - (let ((symbols '())) - (ext:map-apropos (lambda (sym) - (unless (keywordp sym) - (push sym symbols))) - string package external-only) - symbols)) - (defun present-symbol-before-p (a b) "Return true if A belongs before B in a printed summary of symbols. Sorted alphabetically by package name and then symbol name, except @@ -718,45 +635,22 @@ (t (string< (package-name pa) (package-name pb))))))) -(defun print-output-to-string (fn) - (with-output-to-string (*standard-output*) - (funcall fn))) - -(defun print-desciption-to-string (object) - (print-output-to-string (lambda () (describe object)))) -(defslimefun describe-symbol (symbol-name) - (print-desciption-to-string (from-string symbol-name))) - -(defslimefun describe-function (symbol-name) - (print-desciption-to-string (symbol-function (from-string symbol-name)))) (defslimefun describe-setf-function (symbol-name) - (print-desciption-to-string + (print-description-to-string (or (ext:info setf inverse (from-string symbol-name)) (ext:info setf expander (from-string symbol-name))))) (defslimefun describe-type (symbol-name) - (print-desciption-to-string + (print-description-to-string (kernel:values-specifier-type (from-string symbol-name)))) (defslimefun describe-class (symbol-name) - (print-desciption-to-string (find-class (from-string symbol-name) nil))) + (print-description-to-string (find-class (from-string symbol-name) nil))) ;;; Macroexpansion -(defun apply-macro-expander (expander string) - (let ((*print-pretty* t) - (*print-length* 20) - (*print-level* 20)) - (to-string (funcall expander (from-string string))))) - -(defslimefun swank-macroexpand-1 (string) - (apply-macro-expander #'macroexpand-1 string)) - -(defslimefun swank-macroexpand (string) - (apply-macro-expander #'macroexpand string)) - (defslimefun swank-macroexpand-all (string) (apply-macro-expander #'walker:macroexpand-all string)) @@ -779,9 +673,6 @@ (defslimefun untrace-all () (untrace)) -(defslimefun disassemble-symbol (symbol-name) - (print-output-to-string (lambda () (disassemble (from-string symbol-name))))) - (defslimefun load-file (filename) (load filename)) Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.3 slime/swank-openmcl.lisp:1.4 --- slime/swank-openmcl.lisp:1.3 Wed Oct 15 18:02:49 2003 +++ slime/swank-openmcl.lisp Wed Oct 15 18:48:30 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.3 2003/10/15 22:02:49 dbarlow Exp $ +;;; $Id: swank-openmcl.lisp,v 1.4 2003/10/15 22:48:30 dbarlow Exp $ ;;; ;;; @@ -128,7 +128,6 @@ (sldb-loop))) (defslimefun-unimplemented interactive-eval-region (string)) -(defslimefun-unimplemented pprint-eval (string)) (defslimefun-unimplemented re-evaluate-defvar (form)) (defslimefun arglist-string (fname) @@ -144,11 +143,6 @@ ;;; Compilation -(defvar *compiler-notes* '()) - -(defun clear-compiler-notes () - (setf *compiler-notes* '())) - (defun condition-function-name (condition) "Return the function name as a symbol from a compiler condition." (symbol-name (car (ccl::compiler-warning-function-name @@ -169,35 +163,10 @@ :buffer-offset 0) *compiler-notes*)) -(defun unix-gettimeofday () - (ccl::rlet ((tv :timeval)) - (#_gettimeofday tv (ccl::%null-ptr)) - (values (ccl::pref tv :timeval.tv_sec) - (ccl::pref tv :timeval.tv_usec)))) - -(defun measure-time-interval (fn) - "Call FN and return the first return value aand the elapsed time. -The time is measured in microseconds." - (multiple-value-bind (start-secs start-usecs) - (unix-gettimeofday) - (let ((value (funcall fn))) - (multiple-value-bind (end-secs end-usecs) - (unix-gettimeofday) - (values value (+ (* (- end-secs start-secs) 1000000) - (- end-usecs start-usecs))))))) - (defmacro with-trapping-compilation-notes (() &body body) `(handler-bind ((ccl::compiler-warning #'handle-compiler-warning)) , at body)) -(defun call-with-compilation-hooks (fn) - (multiple-value-bind (result usecs) - (with-trapping-compilation-notes () - (clear-compiler-notes) - (measure-time-interval fn)) - (list (to-string result) - (format nil "~,2F" (/ usecs 1000000.0))))) - (defslimefun swank-compile-string (string buffer start) (declare (ignore buffer start)) (call-with-compilation-hooks @@ -212,8 +181,6 @@ (lambda () (compile-file filename :load load)))) -(defslimefun compiler-notes-for-emacs () - (reverse *compiler-notes*)) (defslimefun-unimplemented compiler-notes-for-file (filename)) @@ -330,20 +297,6 @@ ;;; Utilities -(defun print-output-to-string (fn) - (with-output-to-string (*standard-output*) - (let ((*debug-io* *standard-output*)) - (funcall fn)))) - -(defun print-description-to-string (object) - (print-output-to-string (lambda () (describe object)))) - -(defslimefun describe-symbol (symbol-name) - (print-description-to-string (from-string symbol-name))) - -(defslimefun describe-function (symbol-name) - (print-description-to-string (from-string symbol-name))) - (defslimefun-unimplemented describe-setf-function (symbol-name)) (defslimefun-unimplemented describe-type (symbol-name)) @@ -359,14 +312,6 @@ ;;; Tracing and Disassembly -(defslimefun disassemble-symbol (symbol-name) - (print-output-to-string - (lambda () (disassemble (from-string symbol-name))))) - -;;; Cross-referencing - -;; I think some of these will never work in OpenMCL... -(defslimefun-unimplemented who-calls (symbol-name package-name)) (defslimefun-unimplemented who-references (symbol-name package-name)) (defslimefun-unimplemented who-binds (symbol-name package-name)) (defslimefun-unimplemented who-sets (symbol-name package-name)) @@ -378,19 +323,7 @@ ;;; Completion (defslimefun-unimplemented completions (string default-package-name)) -(defslimefun-unimplemented list-all-package-names ()) ;;; Macroexpansion -(defun apply-macro-expander (expander string) - (let ((*print-pretty* t) - (*print-length* 20) - (*print-level* 20)) - (to-string (funcall expander (from-string string))))) - -(defslimefun swank-macroexpand-1 (string) - (apply-macro-expander #'macroexpand-1 string)) - -(defslimefun swank-macroexpand (string) - (apply-macro-expander #'macroexpand string)) (defslimefun-unimplemented swank-macroexpand-all (string)) Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.3 slime/swank-sbcl.lisp:1.4 --- slime/swank-sbcl.lisp:1.3 Wed Oct 15 18:02:49 2003 +++ slime/swank-sbcl.lisp Wed Oct 15 18:48:30 2003 @@ -132,14 +132,15 @@ ;;; Utilities (defvar *swank-debugger-condition*) -(defvar *swank-debugger-hook*) (defvar *swank-debugger-stack-frame*) +(defvar *swank-debugger-hook*) (defun swank-debugger-hook (condition hook) (let ((*swank-debugger-condition* condition) (*swank-debugger-hook* hook)) (sldb-loop))) +;;; this looks portable, but why no openmcl support? (defslimefun interactive-eval-region (string) (let ((*package* *buffer-package*)) (with-input-from-string (stream string) @@ -149,16 +150,6 @@ do (force-output) finally (return (format nil "~{~S~^, ~}" result)))))) -(defslimefun pprint-eval (string) - (let ((*package* *buffer-package*)) - (let ((value (eval (read-from-string string)))) - (let ((*print-pretty* t) - (*print-circle* t) - (*print-level* nil) - (*print-length* nil)) - (with-output-to-string (stream) - (pprint value stream)))))) - (defslimefun re-evaluate-defvar (form) (let ((*package* *buffer-package*)) (let ((form (read-from-string form))) @@ -169,9 +160,7 @@ (makunbound name) (prin1-to-string (eval form)))))) -(defslimefun set-package (package) - (setq *package* (guess-package-from-string package)) - (package-name *package*)) + ;;; adapted from cmucl (defslimefun set-default-directory (directory) @@ -190,24 +179,6 @@ (princ-to-string arglist) "(-- )"))))) -;;;; Compilation Commands. - -(defvar *compiler-notes* '() - "List of compiler notes for the last compilation unit.") - -(defun clear-compiler-notes () (setf *compiler-notes* '())) - -(defvar *notes-database* (make-hash-table :test #'equal) - "Database of recorded compiler notes/warnings/erros (keyed by filename). -Each value is a list of (LOCATION SEVERITY MESSAGE CONTEXT) lists. - LOCATION is a position in the source code (integer or source path). - SEVERITY is one of :ERROR, :WARNING, and :NOTE. - MESSAGE is a string describing the note. - CONTEXT is a string giving further details of where the error occured.") - -(defun clear-note-database (filename) - (remhash (canonicalize-filename filename) *notes-database*)) - (defvar *buffername*) (defvar *buffer-offset*) @@ -272,44 +243,12 @@ (reverse (sb-c::compiler-error-context-original-source-path context))))) -(defslimefun features () - (mapcar #'symbol-name *features*)) - -(defun canonicalize-filename (filename) - (namestring (truename filename))) - -(defslimefun compiler-notes-for-file (filename) - "Return the compiler notes recorded for FILENAME. -\(See *NOTES-DATABASE* for a description of the return type.)" - (gethash (canonicalize-filename filename) *notes-database*)) - -(defslimefun compiler-notes-for-emacs () - "Return the list of compiler notes for the last compilation unit." - (reverse *compiler-notes*)) - -(defun measure-time-interval (fn) - "Call FN and return the first return value and the elapsed time. -The time is measured in microseconds." - (let ((before (get-internal-real-time))) - (values - (funcall fn) - (* (- (get-internal-real-time) before) - (/ 1000000 internal-time-units-per-second))))) - (defmacro with-trapping-compilation-notes (() &body body) `(handler-bind ((sb-c:compiler-error #'handle-notification-condition) (style-warning #'handle-notification-condition) (warning #'handle-notification-condition)) , at body)) -(defun call-with-compilation-hooks (fn) - (multiple-value-bind (result usecs) - (with-trapping-compilation-notes () - (clear-compiler-notes) - (measure-time-interval fn)) - (list (to-string result) - (format nil "~,2F" (/ usecs 1000000.0))))) - (defslimefun swank-compile-file (filename load) (call-with-compilation-hooks (lambda () @@ -320,7 +259,6 @@ (ret (compile-file filename))) (if load (load ret) ret))))) - (defslimefun swank-compile-string (string buffer start) (call-with-compilation-hooks (lambda () @@ -403,8 +341,7 @@ (and (<= (length s1) (length s2)) (string-equal s1 s2 :end2 (length s1)))) -(defslimefun list-all-package-names () - (mapcar #'package-name (list-all-packages))) + ;;;; Definitions @@ -508,11 +445,6 @@ (let ((y (funcall f x))) (and y (list y))))) -(defun apropos-symbols (string &optional external-only package) - "Return the symbols matching an apropos search." - ;; CMUCL used ext:map-apropos here, not sure why - (remove-if #'keywordp (apropos-list string package external-only))) - (defun present-symbol-before-p (a b) "Return true if A belongs before B in a printed summary of symbols. Sorted alphabetically by package name and then symbol name, except @@ -529,46 +461,18 @@ (t (string< (package-name pa) (package-name pb))))))) -(defun print-output-to-string (fn) - (with-output-to-string (*standard-output*) - (funcall fn))) - -(defun print-desciption-to-string (object) - (print-output-to-string (lambda () (describe object)))) - -(defslimefun describe-symbol (symbol-name) - (print-desciption-to-string (from-string symbol-name))) - -(defslimefun describe-function (symbol-name) - (print-desciption-to-string (symbol-function (from-string symbol-name)))) (defslimefun describe-setf-function (symbol-name) - (print-desciption-to-string `(setf ,(from-string symbol-name)))) + (print-description-to-string `(setf ,(from-string symbol-name)))) (defslimefun describe-type (symbol-name) - (print-desciption-to-string + (print-description-to-string (sb-kernel:values-specifier-type (from-string symbol-name)))) (defslimefun describe-class (symbol-name) - (print-desciption-to-string (find-class (from-string symbol-name) nil))) - -;;; Macroexpansion - -(defun apply-macro-expander (expander string) - (let ((*print-pretty* t) - (*print-length* 20) - (*print-level* 20)) - (to-string (funcall expander (from-string string))))) + (print-description-to-string (find-class (from-string symbol-name) nil))) -(defslimefun swank-macroexpand-1 (string) - (apply-macro-expander #'macroexpand-1 string)) - -(defslimefun swank-macroexpand (string) - (apply-macro-expander #'macroexpand string)) - -#+nil -(defslimefun swank-macroexpand-all (string) - (apply-macro-expander #'sb-walker:macroexpand-all string)) +;;; macroexpansion (defslimefun-unimplemented swank-macroexpand-all (string)) @@ -590,8 +494,7 @@ (defslimefun untrace-all () (untrace)) -(defslimefun disassemble-symbol (symbol-name) - (print-output-to-string (lambda () (disassemble (from-string symbol-name))))) + (defslimefun load-file (filename) (load filename)) Index: slime/swank.lisp diff -u slime/swank.lisp:1.28 slime/swank.lisp:1.29 --- slime/swank.lisp:1.28 Wed Oct 15 18:02:49 2003 +++ slime/swank.lisp Wed Oct 15 18:48:30 2003 @@ -161,9 +161,115 @@ (force-output) (format nil "~{~S~^, ~}" values))) +;;; this was unimplemented in -openmcl, anyone know why? +;;; ditto interactive-eval-region +(defslimefun pprint-eval (string) + (let ((*package* *buffer-package*)) + (let ((value (eval (read-from-string string)))) + (let ((*print-pretty* t) + (*print-circle* t) + (*print-level* nil) + #+cmu (ext:*gc-verbose* nil) + (*print-length* nil)) + (with-output-to-string (stream) + (pprint value stream)))))) +(defslimefun set-package (package) + (setq *package* (guess-package-from-string package)) + (package-name *package*)) +;;;; Compilation Commands. + +(defvar *compiler-notes* '() + "List of compiler notes for the last compilation unit.") + +(defun clear-compiler-notes () + (setf *compiler-notes* '()) + (setf *previous-compiler-condition* nil) + (setf *previous-context* nil)) + +(defvar *notes-database* (make-hash-table :test #'equal) + "Database of recorded compiler notes/warnings/erros (keyed by filename). +Each value is a list of (LOCATION SEVERITY MESSAGE CONTEXT) lists. + LOCATION is a position in the source code (integer or source path). + SEVERITY is one of :ERROR, :WARNING, and :NOTE. + MESSAGE is a string describing the note. + CONTEXT is a string giving further details of where the error occured.") + +(defun clear-note-database (filename) + (remhash (canonicalize-filename filename) *notes-database*)) + +(defslimefun features () + (mapcar #'symbol-name *features*)) + +(defun canonicalize-filename (filename) + (namestring (truename filename))) + +(defslimefun compiler-notes-for-file (filename) + "Return the compiler notes recorded for FILENAME. +\(See *NOTES-DATABASE* for a description of the return type.)" + (gethash (canonicalize-filename filename) *notes-database*)) + +(defun measure-time-interval (fn) + "Call FN and return the first return value and the elapsed time. +The time is measured in microseconds." + (let ((before (get-internal-real-time))) + (values + (funcall fn) + (* (- (get-internal-real-time) before) + (/ 1000000 internal-time-units-per-second))))) + +(defun call-with-compilation-hooks (fn) + (multiple-value-bind (result usecs) + (with-trapping-compilation-notes () + (clear-compiler-notes) + (measure-time-interval fn)) + (list (to-string result) + (format nil "~,2F" (/ usecs 1000000.0))))) + +(defslimefun list-all-package-names () + (mapcar #'package-name (list-all-packages))) + +(defun apropos-symbols (string &optional external-only package) + "Return the symbols matching an apropos search." + ;; CMUCL used ext:map-apropos here, not sure why + (remove-if #'keywordp (apropos-list string package external-only))) + + +(defun print-output-to-string (fn) + (with-output-to-string (*standard-output*) + (let ((*debug-io* *standard-output*)) + (funcall fn)))) + +(defun print-description-to-string (object) + (print-output-to-string (lambda () (describe object)))) + +(defslimefun describe-symbol (symbol-name) + (print-description-to-string (from-string symbol-name))) + +(defslimefun describe-function (symbol-name) + (print-description-to-string (symbol-function (from-string symbol-name)))) + +;;; Macroexpansion + +(defun apply-macro-expander (expander string) + (let ((*print-pretty* t) + (*print-length* 20) + (*print-level* 20)) + (to-string (funcall expander (from-string string))))) + +(defslimefun swank-macroexpand-1 (string) + (apply-macro-expander #'macroexpand-1 string)) + +(defslimefun swank-macroexpand (string) + (apply-macro-expander #'macroexpand string)) + +(defslimefun disassemble-symbol (symbol-name) + (print-output-to-string (lambda () (disassemble (from-string symbol-name))))) + + +;;;; now pull the per-backend stuff in (eval-when (:compile-toplevel) (compile-file swank::*sysdep-pathname*)) (eval-when (:load-toplevel :execute) (load swank::*sysdep-pathname*)) From dbarlow at common-lisp.net Wed Oct 15 23:02:27 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Wed, 15 Oct 2003 19:02:27 -0400 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26765 Modified Files: swank-openmcl.lisp Log Message: missed a bit Date: Wed Oct 15 19:02:27 2003 Author: dbarlow Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.4 slime/swank-openmcl.lisp:1.5 --- slime/swank-openmcl.lisp:1.4 Wed Oct 15 18:48:30 2003 +++ slime/swank-openmcl.lisp Wed Oct 15 19:02:26 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.4 2003/10/15 22:48:30 dbarlow Exp $ +;;; $Id: swank-openmcl.lisp,v 1.5 2003/10/15 23:02:26 dbarlow Exp $ ;;; ;;; @@ -181,9 +181,6 @@ (lambda () (compile-file filename :load load)))) - -(defslimefun-unimplemented compiler-notes-for-file (filename)) - ;;; Debugging (defvar *sldb-level* 0) @@ -302,9 +299,6 @@ (defslimefun describe-class (symbol-name) (print-description-to-string (find-class (from-string symbol-name) nil))) - -(defslimefun features () - (mapcar #'symbol-name *features*)) (defslimefun-unimplemented apropos-list-for-emacs (name &optional external-only From dbarlow at common-lisp.net Thu Oct 16 02:05:57 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Wed, 15 Oct 2003 22:05:57 -0400 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9614 Modified Files: swank.lisp Log Message: silly packaging mistake Date: Wed Oct 15 22:05:56 2003 Author: dbarlow Index: slime/swank.lisp diff -u slime/swank.lisp:1.29 slime/swank.lisp:1.30 --- slime/swank.lisp:1.29 Wed Oct 15 18:48:30 2003 +++ slime/swank.lisp Wed Oct 15 22:05:56 2003 @@ -39,7 +39,7 @@ (defun start-server (&optional (port server-port)) "Start the Slime backend on TCP port `port'." - (swank-impl:create-swank-server port :reuse-address t) + (create-swank-server port :reuse-address t) #+xref (setf c:*record-xref-info* t) (when *swank-debug-p* (format *debug-io* "~&;; Swank ready.~%"))) From heller at common-lisp.net Thu Oct 16 11:08:40 2003 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 16 Oct 2003 07:08:40 -0400 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5887 Modified Files: swank.lisp Log Message: swank::*sysdep-pathname*: Use defparameter so that cmucl loads the fasl file. (compiler-notes-for-emacs): Got lost during refactoring. Date: Thu Oct 16 07:08:40 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.30 slime/swank.lisp:1.31 --- slime/swank.lisp:1.30 Wed Oct 15 22:05:56 2003 +++ slime/swank.lisp Thu Oct 16 07:08:40 2003 @@ -14,7 +14,7 @@ (:export #:start-server))) (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar swank::*sysdep-pathname* + (defparameter swank::*sysdep-pathname* (merge-pathnames (or #+cmu "swank-cmucl" #+(and sbcl sb-thread) "swank-sbcl" #+openmcl "swank-openmcl") @@ -22,6 +22,7 @@ *default-pathname-defaults*)))) (in-package :swank) + (defvar *swank-io-package* (let ((package (make-package "SWANK-IO-PACKAGE"))) (import '(nil t quote) package) @@ -97,11 +98,12 @@ (force-output *emacs-io*))) (defun prin1-to-string-for-emacs (object) - (let ((*print-case* :downcase) - (*print-readably* nil) - (*print-pretty* nil) - (*package* *swank-io-package*)) - (prin1-to-string object))) + (with-standard-io-syntax + (let ((*print-case* :downcase) + (*print-readably* nil) + (*print-pretty* nil) + (*package* *swank-io-package*)) + (prin1-to-string object)))) ;;; The Reader @@ -112,7 +114,6 @@ EVAL-STRING binds *buffer-package*. Strings originating from a slime buffer are best read in this package. See also FROM-STRING and TO-STRING.") - (defun from-string (string) "Read string in the *BUFFER-PACKAGE*" (let ((*package* *buffer-package*)) @@ -129,7 +130,6 @@ (find-package (string-upcase name)))) *package*)) - ;;; public interface. slimefuns are the things that emacs is allowed ;;; to call @@ -169,7 +169,6 @@ (let ((*print-pretty* t) (*print-circle* t) (*print-level* nil) - #+cmu (ext:*gc-verbose* nil) (*print-length* nil)) (with-output-to-string (stream) (pprint value stream)))))) @@ -178,7 +177,6 @@ (setq *package* (guess-package-from-string package)) (package-name *package*)) - ;;;; Compilation Commands. (defvar *compiler-notes* '() @@ -211,6 +209,10 @@ \(See *NOTES-DATABASE* for a description of the return type.)" (gethash (canonicalize-filename filename) *notes-database*)) +(defslimefun compiler-notes-for-emacs () + "Return the list of compiler notes for the last compilation unit." + (reverse *compiler-notes*)) + (defun measure-time-interval (fn) "Call FN and return the first return value and the elapsed time. The time is measured in microseconds." @@ -236,7 +238,6 @@ ;; CMUCL used ext:map-apropos here, not sure why (remove-if #'keywordp (apropos-list string package external-only))) - (defun print-output-to-string (fn) (with-output-to-string (*standard-output*) (let ((*debug-io* *standard-output*)) @@ -276,4 +277,4 @@ ;;; Local Variables: ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) -;;; End: +;;; End From heller at common-lisp.net Thu Oct 16 11:10:48 2003 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 16 Oct 2003 07:10:48 -0400 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7958 Modified Files: swank-cmucl.lisp Log Message: (read-next-form): Isn't quite portable. Redefine it here. (read-symbol/package): Deleted. (Was not used.) (function-source-location): Deal with struct-slot setters. Date: Thu Oct 16 07:10:48 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.3 slime/swank-cmucl.lisp:1.4 --- slime/swank-cmucl.lisp:1.3 Wed Oct 15 18:48:30 2003 +++ slime/swank-cmucl.lisp Thu Oct 16 07:10:48 2003 @@ -82,14 +82,16 @@ (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*)) (close *emacs-io*))))) - -(defun read-symbol/package (symbol-name package-name) - (let ((package (find-package package-name))) - (unless package (error "No such package: ~S" package-name)) - (handler-case - (let ((*package* package)) - (read-from-string symbol-name)) - (reader-error () nil)))) +(defun read-next-form () + (handler-case + (let* ((length (logior (ash (read-byte *emacs-io*) 16) + (ash (read-byte *emacs-io*) 8) + (read-byte *emacs-io*))) + (string (make-string length))) + (sys:read-n-bytes *emacs-io* string 0 length) + (read-form string)) + (condition (c) + (throw 'serve-request-catcher c)))) ;;; Asynchronous eval @@ -128,8 +130,6 @@ ;;;; Compilation Commands - - (defvar *previous-compiler-condition* nil "Used to detect duplicates.") @@ -508,21 +508,25 @@ (vm::find-code-object function)) (not (eq closure function)))) -(defun struct-accessor-p (function) - (function-code-object= function #'kernel::structure-slot-accessor)) +(defun struct-closure-p (function) + (or (function-code-object= function #'kernel::structure-slot-accessor) + (function-code-object= function #'kernel::structure-slot-setter) + (function-code-object= function #'kernel::%defstruct))) -(defun struct-accessor-dd (function) - (kernel:layout-info (kernel:%closure-index-ref function 2))) - -(defun struct-misc-op-p (function) - (function-code-object= function #'kernel::%defstruct)) - -(defun struct-misc-op-dd (function) +(defun struct-closure-dd (function) (assert (= (kernel:get-type function) vm:closure-header-type)) - (kernel:layout-info - (c:value-cell-ref - (sys:find-if-in-closure #'di::indirect-value-cell-p function)))) - + (flet ((find-layout (function) + (sys:find-if-in-closure + (lambda (x) + (cond ((kernel::layout-p x) + (return-from find-layout x)) + ((di::indirect-value-cell-p x) + (let ((value (c:value-cell-ref x))) + (when (kernel::layout-p value) + (return-from find-layout value)))))) + function))) + (kernel:layout-info (find-layout function)))) + (defun dd-source-location (dd) (let ((constructor (or (kernel:dd-default-constructor dd) (car (kernel::dd-constructors dd))))) @@ -543,10 +547,8 @@ ;; ;; For an ordinary function we return the source location of the ;; first code-location we find. - (cond ((struct-accessor-p function) - (dd-source-location (struct-accessor-dd function))) - ((struct-misc-op-p function) - (dd-source-location (struct-misc-op-dd function))) + (cond ((struct-closure-p function) + (dd-source-location (struct-closure-dd function))) (t (let ((location (function-first-code-location function))) (when location @@ -964,7 +966,7 @@ (defslimefun describe-inspectee () "Describe the currently inspected object." - (print-desciption-to-string *inspectee*)) + (print-description-to-string *inspectee*)) (defgeneric inspected-parts (object) (:documentation From heller at common-lisp.net Thu Oct 16 11:13:06 2003 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 16 Oct 2003 07:13:06 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8856 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Thu Oct 16 07:13:06 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.30 slime/ChangeLog:1.31 --- slime/ChangeLog:1.30 Wed Oct 15 17:24:33 2003 +++ slime/ChangeLog Thu Oct 16 07:13:06 2003 @@ -1,3 +1,7 @@ +2003-10-16 Helmut Eller + + * swank-cmucl.lisp, swank.lisp: Fix CMUCL support. + 2003-10-15 Daniel Barlow * swank.lisp: rearrange the backends. rename swank.lisp to From lgorrie at common-lisp.net Thu Oct 16 16:07:51 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 16 Oct 2003 12:07:51 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7431 Modified Files: slime.el Log Message: (slime-swank-connection-retries): New default value is `nil', which means unlimited retries (until user aborts). Retry interval also reduced from once per second to four times per second. Date: Thu Oct 16 12:07:51 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.33 slime/slime.el:1.34 --- slime/slime.el:1.33 Wed Oct 15 13:39:40 2003 +++ slime/slime.el Thu Oct 16 12:07:51 2003 @@ -72,8 +72,9 @@ The default value is automatically computed from the location of the Emacs Lisp package.") -(defvar slime-swank-connection-retries 10 - "Number of times to try connecting to the Swank server before aborting.") +(defvar slime-swank-connection-retries nil + "Number of times to try connecting to the Swank server before aborting. +Nil means never give up.") (defvar slime-lisp-binary-extension ".x86f" "Filename extension for Lisp object files.") @@ -488,18 +489,22 @@ (read-string "Port: " (number-to-string slime-swank-port)))) (or (ignore-errors (string-to-number port)) port)))) - (setq retries (or retries slime-swank-connection-retries)) - (if (zerop retries) - (error "Unable to contact Swank server.") - (if (slime-net-connect host port) - (progn (slime-init-dispatcher) - (slime-fetch-features-list) - (message "Connected to Swank on %s:%S. %s" - host port (slime-random-words-of-encouragement))) - (message "Connecting to Swank (%S attempts remaining)." - retries) - (sit-for 1) - (slime-connect host port (1- retries))))) + (let ((retries slime-swank-connection-retries)) + (while (and (not (slime-connected-p)) + (or (null retries) + (> (decf retries) 0))) + (message "Connecting to Swank at %s:%S%s..." + host port (if retries + (format " (%S attempts remaining)" retries) + "")) + (if (slime-net-connect host port) + (progn (slime-init-dispatcher) + (slime-fetch-features-list) + (message "Connected to Swank on %s:%S. %s" + host port (slime-random-words-of-encouragement))) + (when (and retries (zerop (decf retries))) + (error "Unable to contact Swank server.")) + (sit-for 0.25))))) (defun slime-start-swank-server () "Start a Swank server on the inferior lisp." @@ -856,9 +861,13 @@ (slime-net-send `(swank:eval-string ,form-string ,package-name))) (defun slime-check-connected () - (unless (and slime-net-process - (eq (process-status slime-net-process) 'open)) + (unless (slime-connected-p) (error "Not connected. Use `M-x slime' to start a Lisp."))) + +(defun slime-connected-p () + "Return true if the Swank connection is open." + (and slime-net-process + (eq (process-status slime-net-process) 'open))) (defun slime-eval-string-async (string package continuation) (when (slime-busy-p) From lgorrie at common-lisp.net Thu Oct 16 16:08:03 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 16 Oct 2003 12:08:03 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7537 Modified Files: ChangeLog Log Message: Date: Thu Oct 16 12:08:03 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.31 slime/ChangeLog:1.32 --- slime/ChangeLog:1.31 Thu Oct 16 07:13:06 2003 +++ slime/ChangeLog Thu Oct 16 12:08:03 2003 @@ -1,3 +1,10 @@ +2003-10-16 Luke Gorrie + + * slime.el (slime-swank-connection-retries): New default value is + `nil', which means unlimited retries (until user aborts). Retry + interval also reduced from once per second to four times per + second. + 2003-10-16 Helmut Eller * swank-cmucl.lisp, swank.lisp: Fix CMUCL support. From lgorrie at common-lisp.net Thu Oct 16 16:10:11 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 16 Oct 2003 12:10:11 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9447 Modified Files: slime.el Log Message: Fixed braino in previous change. Date: Thu Oct 16 12:10:11 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.34 slime/slime.el:1.35 --- slime/slime.el:1.34 Thu Oct 16 12:07:51 2003 +++ slime/slime.el Thu Oct 16 12:10:10 2003 @@ -490,9 +490,7 @@ (number-to-string slime-swank-port)))) (or (ignore-errors (string-to-number port)) port)))) (let ((retries slime-swank-connection-retries)) - (while (and (not (slime-connected-p)) - (or (null retries) - (> (decf retries) 0))) + (while (not (slime-connected-p)) (message "Connecting to Swank at %s:%S%s..." host port (if retries (format " (%S attempts remaining)" retries) From lgorrie at common-lisp.net Thu Oct 16 20:05:22 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 16 Oct 2003 16:05:22 -0400 Subject: [slime-cvs] CVS update: slime/swank.lisp slime/swank-sbcl.lisp slime/swank-openmcl.lisp slime/swank-cmucl.lisp slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8204 Modified Files: swank.lisp swank-sbcl.lisp swank-openmcl.lisp swank-cmucl.lisp ChangeLog Log Message: The macro `with-trapping-compiler-notes' is now defined in the portable code, and expands to a call to the backend-defined `call-trapping-compiler-notes' with the body wrapped in a lambda. This is to avoid swank.lisp referring to macros in the backends -- it gets compiled first so it thinks they're functions. Date: Thu Oct 16 16:05:21 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.31 slime/swank.lisp:1.32 --- slime/swank.lisp:1.31 Thu Oct 16 07:08:40 2003 +++ slime/swank.lisp Thu Oct 16 16:05:21 2003 @@ -222,6 +222,9 @@ (* (- (get-internal-real-time) before) (/ 1000000 internal-time-units-per-second))))) +(defmacro with-trapping-compiler-notes (() &body body) + `(call-trapping-compiler-notes (lambda () , at body))) + (defun call-with-compilation-hooks (fn) (multiple-value-bind (result usecs) (with-trapping-compilation-notes () Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.4 slime/swank-sbcl.lisp:1.5 --- slime/swank-sbcl.lisp:1.4 Wed Oct 15 18:48:30 2003 +++ slime/swank-sbcl.lisp Thu Oct 16 16:05:21 2003 @@ -243,11 +243,11 @@ (reverse (sb-c::compiler-error-context-original-source-path context))))) -(defmacro with-trapping-compilation-notes (() &body body) - `(handler-bind ((sb-c:compiler-error #'handle-notification-condition) - (style-warning #'handle-notification-condition) - (warning #'handle-notification-condition)) - , at body)) +(defun call-trapping-compilation-notes (fn) + (handler-bind ((sb-c:compiler-error #'handle-notification-condition) + (style-warning #'handle-notification-condition) + (warning #'handle-notification-condition)) + (funcall fn))) (defslimefun swank-compile-file (filename load) (call-with-compilation-hooks Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.5 slime/swank-openmcl.lisp:1.6 --- slime/swank-openmcl.lisp:1.5 Wed Oct 15 19:02:26 2003 +++ slime/swank-openmcl.lisp Thu Oct 16 16:05:21 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.5 2003/10/15 23:02:26 dbarlow Exp $ +;;; $Id: swank-openmcl.lisp,v 1.6 2003/10/16 20:05:21 lgorrie Exp $ ;;; ;;; @@ -163,9 +163,9 @@ :buffer-offset 0) *compiler-notes*)) -(defmacro with-trapping-compilation-notes (() &body body) - `(handler-bind ((ccl::compiler-warning #'handle-compiler-warning)) - , at body)) +(defmacro call-trapping-compilation-notes (fn) + (handler-bind ((ccl::compiler-warning #'handle-compiler-warning)) + (funcall fn))) (defslimefun swank-compile-string (string buffer start) (declare (ignore buffer start)) Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.4 slime/swank-cmucl.lisp:1.5 --- slime/swank-cmucl.lisp:1.4 Thu Oct 16 07:10:48 2003 +++ slime/swank-cmucl.lisp Thu Oct 16 16:05:21 2003 @@ -211,11 +211,11 @@ (reverse (c::compiler-error-context-original-source-path context))))) -(defmacro with-trapping-compilation-notes (() &body body) - `(handler-bind ((c::compiler-error #'handle-notification-condition) - (c::style-warning #'handle-notification-condition) - (c::warning #'handle-notification-condition)) - , at body)) +(defmacro call-trapping-compilation-notes (fn) + (handler-bind ((c::compiler-error #'handle-notification-condition) + (c::style-warning #'handle-notification-condition) + (c::warning #'handle-notification-condition)) + (funcall fn))) (defslimefun swank-compile-file (filename load) (call-with-compilation-hooks Index: slime/ChangeLog diff -u slime/ChangeLog:1.32 slime/ChangeLog:1.33 --- slime/ChangeLog:1.32 Thu Oct 16 12:08:03 2003 +++ slime/ChangeLog Thu Oct 16 16:05:21 2003 @@ -1,5 +1,11 @@ 2003-10-16 Luke Gorrie + * swank*.lisp (with-trapping-compiler-notes): This macro is now + defined here, and expands to a call to the backend-defined + `call-trapping-compiler-notes' with the body wrapped in a + lambda. This is to avoid swank.lisp referring to macros in the + backends -- it gets compiled first so it thinks they're functions. + * slime.el (slime-swank-connection-retries): New default value is `nil', which means unlimited retries (until user aborts). Retry interval also reduced from once per second to four times per From lgorrie at common-lisp.net Thu Oct 16 21:03:37 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 16 Oct 2003 17:03:37 -0400 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5307 Modified Files: swank-openmcl.lisp swank-cmucl.lisp Log Message: Fixed braino in previous change: call-trapping-compilation-notes was left as a macro. Date: Thu Oct 16 17:03:37 2003 Author: lgorrie Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.6 slime/swank-openmcl.lisp:1.7 --- slime/swank-openmcl.lisp:1.6 Thu Oct 16 16:05:21 2003 +++ slime/swank-openmcl.lisp Thu Oct 16 17:03:37 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.6 2003/10/16 20:05:21 lgorrie Exp $ +;;; $Id: swank-openmcl.lisp,v 1.7 2003/10/16 21:03:37 lgorrie Exp $ ;;; ;;; @@ -163,7 +163,7 @@ :buffer-offset 0) *compiler-notes*)) -(defmacro call-trapping-compilation-notes (fn) +(defun call-trapping-compilation-notes (fn) (handler-bind ((ccl::compiler-warning #'handle-compiler-warning)) (funcall fn))) Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.5 slime/swank-cmucl.lisp:1.6 --- slime/swank-cmucl.lisp:1.5 Thu Oct 16 16:05:21 2003 +++ slime/swank-cmucl.lisp Thu Oct 16 17:03:37 2003 @@ -211,7 +211,7 @@ (reverse (c::compiler-error-context-original-source-path context))))) -(defmacro call-trapping-compilation-notes (fn) +(defun call-trapping-compilation-notes (fn) (handler-bind ((c::compiler-error #'handle-notification-condition) (c::style-warning #'handle-notification-condition) (c::warning #'handle-notification-condition)) From lgorrie at common-lisp.net Thu Oct 16 21:03:57 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 16 Oct 2003 17:03:57 -0400 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5401 Modified Files: swank.lisp Log Message: Fixed braino in previous change. Date: Thu Oct 16 17:03:57 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.32 slime/swank.lisp:1.33 --- slime/swank.lisp:1.32 Thu Oct 16 16:05:21 2003 +++ slime/swank.lisp Thu Oct 16 17:03:57 2003 @@ -222,8 +222,8 @@ (* (- (get-internal-real-time) before) (/ 1000000 internal-time-units-per-second))))) -(defmacro with-trapping-compiler-notes (() &body body) - `(call-trapping-compiler-notes (lambda () , at body))) +(defmacro with-trapping-compilation-notes (() &body body) + `(call-trapping-compilation-notes (lambda () , at body))) (defun call-with-compilation-hooks (fn) (multiple-value-bind (result usecs) From lgorrie at common-lisp.net Thu Oct 16 21:28:21 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 16 Oct 2003 17:28:21 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19243 Modified Files: slime.el Log Message: (slime-forward-source-path): Improved somewhat. Seems to work for all common cases except backquote. Backquote is tricky, because the source-paths are based on the reader's expansion, e.g.: * (let ((*print-pretty* nil)) (print (read-from-string "`(a ,@(b c) d)"))) --> (COMMON-LISP::BACKQ-CONS (QUOTE A) (COMMON-LISP::BACKQ-APPEND (B C) (QUOTE (D)))) Must investigate whether we need to write a hairy backquote-traversing state machine or whether this is something that could be fixed in CMUCL. Date: Thu Oct 16 17:28:21 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.35 slime/slime.el:1.36 --- slime/slime.el:1.35 Thu Oct 16 12:10:10 2003 +++ slime/slime.el Thu Oct 16 17:28:20 2003 @@ -1153,21 +1153,29 @@ (defun slime-visit-source-path (source-path) "Visit a full source path including the top-level form." - (ignore-errors - (goto-char (point-min)) - (slime-forward-sexp (car source-path)) - (slime-forward-source-path (cdr source-path)))) + (goto-char (point-min)) + (slime-forward-source-path source-path)) + +(defun slime-forward-positioned-source-path (source-path) + "Move forward through a sourcepath from a fixed position. +The point is assumed to already be at the outermost sexp, making the +first element of the source-path redundant." + (ignore-errors (down-list 1)) + (slime-forward-source-path (cdr source-path))) (defun slime-forward-source-path (source-path) (let ((origin (point))) - (cond ((null source-path) - (or (ignore-errors (down-list 1) (backward-char 1) t) - (goto-char origin))) - (t - (or (ignore-errors (down-list 1) - (slime-forward-sexp (car source-path)) - (slime-forward-source-path (cdr source-path))) - (goto-char origin)))))) + (condition-case nil + (progn + (loop for form-number in source-path + for more downfrom (1- (length source-path)) + do (progn + (slime-forward-sexp form-number) + (unless (zerop more) (down-list 1)))) + ;; Align at beginning + (slime-forward-sexp) + (beginning-of-sexp)) + (error (goto-char origin))))) (defun slime-goto-location (note) "Move to the location fiven with the note NOTE. @@ -1204,11 +1212,11 @@ (goto-char (plist-get note ':position)) ;; Drop the the toplevel form from the source-path and go the ;; expression. - (slime-forward-source-path (cdr (plist-get note ':source-path)))) + (slime-forward-positioned-source-path (plist-get note ':source-path))) ((stringp (plist-get note :buffername)) (assert (string= (buffer-name) (plist-get note :buffername))) (goto-char (plist-get note :buffer-offset)) - (slime-forward-source-path (cdr (plist-get note ':source-path)))) + (slime-forward-positioned-source-path (plist-get note ':source-path))) (t (error "Unsupported location type %s" note)))) @@ -1260,11 +1268,6 @@ ;; skip this sexp (slime-forward-sexp))))) -(defun slime-beginning-of-next-sexp () - "Move the point to the first character of the next sexp." - (forward-sexp) - (backward-sexp)) - (defun slime-eval-feature-conditional (e) "Interpret a reader conditional expression." (if (symbolp e) @@ -2249,8 +2252,8 @@ #'switch-to-buffer) (get-buffer buffer)) (goto-char offset) - (slime-forward-source-path - (cdr (plist-get source-location :path))))) + (slime-forward-positioned-source-path + (plist-get source-location :path)))) (t (error "Cannot locate source from stream: %s" source-location))))) From lgorrie at common-lisp.net Thu Oct 16 21:28:38 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 16 Oct 2003 17:28:38 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19320 Modified Files: ChangeLog Log Message: Date: Thu Oct 16 17:28:38 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.33 slime/ChangeLog:1.34 --- slime/ChangeLog:1.33 Thu Oct 16 16:05:21 2003 +++ slime/ChangeLog Thu Oct 16 17:28:38 2003 @@ -1,5 +1,19 @@ 2003-10-16 Luke Gorrie + * slime.el (slime-forward-source-path): Improved somewhat. Seems + to work for all common cases except backquote. Backquote is + tricky, because the source-paths are based on the reader's + expansion, e.g.: + * (let ((*print-pretty* nil)) + (print (read-from-string "`(a ,@(b c) d)"))) + --> + (COMMON-LISP::BACKQ-CONS (QUOTE A) + (COMMON-LISP::BACKQ-APPEND (B C) + (QUOTE (D)))) + Must investigate whether we need to write a hairy + backquote-traversing state machine or whether this is something + that could be fixed in CMUCL. + * swank*.lisp (with-trapping-compiler-notes): This macro is now defined here, and expands to a call to the backend-defined `call-trapping-compiler-notes' with the body wrapped in a From lgorrie at common-lisp.net Thu Oct 16 21:29:14 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 16 Oct 2003 17:29:14 -0400 Subject: [slime-cvs] CVS update: slime/test.sh Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20548 Modified Files: test.sh Log Message: Added: (setq debug-on-quit t) (setq slime-swank-connection-retries 50) Date: Thu Oct 16 17:29:14 2003 Author: lgorrie Index: slime/test.sh diff -u slime/test.sh:1.1 slime/test.sh:1.2 --- slime/test.sh:1.1 Wed Oct 15 10:44:11 2003 +++ slime/test.sh Thu Oct 16 17:29:14 2003 @@ -29,6 +29,8 @@ # you can remove "--batch" to get an emacs window for troubleshooting. $emacs --batch --no-site-file --no-init-file \ + --eval "(setq debug-on-quit t)" \ + --eval "(setq slime-swank-connection-retries 50)" \ --eval "(setq load-path (cons \"$testdir\" load-path))" \ --eval "(require 'slime)" \ --eval "(setq inferior-lisp-program \"$lisp\")" \ From lgorrie at common-lisp.net Thu Oct 16 21:29:34 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 16 Oct 2003 17:29:34 -0400 Subject: [slime-cvs] CVS update: slime/.cvsignore Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20627 Added Files: .cvsignore Log Message: *** empty log message *** Date: Thu Oct 16 17:29:34 2003 Author: lgorrie From lgorrie at common-lisp.net Thu Oct 16 22:56:38 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 16 Oct 2003 18:56:38 -0400 Subject: [slime-cvs] CVS update: slime/test.sh Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6070 Modified Files: test.sh Log Message: Don't bother limiting retries. Increase max-lisp-eval-depth (possibly cheating) Date: Thu Oct 16 18:56:37 2003 Author: lgorrie Index: slime/test.sh diff -u slime/test.sh:1.2 slime/test.sh:1.3 --- slime/test.sh:1.2 Thu Oct 16 17:29:14 2003 +++ slime/test.sh Thu Oct 16 18:56:37 2003 @@ -30,7 +30,7 @@ # you can remove "--batch" to get an emacs window for troubleshooting. $emacs --batch --no-site-file --no-init-file \ --eval "(setq debug-on-quit t)" \ - --eval "(setq slime-swank-connection-retries 50)" \ + --eval "(setq max-lisp-eval-depth 1000)" \ --eval "(setq load-path (cons \"$testdir\" load-path))" \ --eval "(require 'slime)" \ --eval "(setq inferior-lisp-program \"$lisp\")" \ From dbarlow at common-lisp.net Fri Oct 17 01:37:33 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Thu, 16 Oct 2003 21:37:33 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4879 Modified Files: ChangeLog Log Message: Date: Thu Oct 16 21:37:33 2003 Author: dbarlow Index: slime/ChangeLog diff -u slime/ChangeLog:1.34 slime/ChangeLog:1.35 --- slime/ChangeLog:1.34 Thu Oct 16 17:28:38 2003 +++ slime/ChangeLog Thu Oct 16 21:37:33 2003 @@ -1,3 +1,18 @@ +2003-10-17 Daniel Barlow + + * swank-sbcl.lisp: Transplanted Helmut's serve-event server to + replace the existing thread-using server. SLIME now has no + dependency on SB-THREAD + + * slime.el (slime-find-buffer-package): handle errors from (read) + for the case where the buffer ends before the in-package form does + (slime-set-package): insert missing comma + (slime-goto-source-location): sbcl has a disagreement with emacs + over the meaning of a character position. Level up with + C-M-f C-M-b + + * assorted typo fixes + 2003-10-16 Luke Gorrie * slime.el (slime-forward-source-path): Improved somewhat. Seems From dbarlow at common-lisp.net Fri Oct 17 01:38:03 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Thu, 16 Oct 2003 21:38:03 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4946 Modified Files: slime.el Log Message: (slime-find-buffer-package): handle errors from (read) for the case where the buffer ends before the in-package form does (slime-set-package): insert missing comma (slime-goto-source-location): sbcl has a disagreement with emacs over the meaning of a character position. Level up with C-M-f C-M-b Date: Thu Oct 16 21:38:03 2003 Author: dbarlow Index: slime/slime.el diff -u slime/slime.el:1.36 slime/slime.el:1.37 --- slime/slime.el:1.36 Thu Oct 16 17:28:20 2003 +++ slime/slime.el Thu Oct 16 21:38:01 2003 @@ -323,7 +323,7 @@ nil t)) (goto-char (match-end 0)) (skip-chars-forward " \n\t\f\r#:") - (let ((pkg (read (current-buffer)))) + (let ((pkg (condition-case nil (read (current-buffer)) (error nil )))) (cond ((stringp pkg) pkg) ((symbolp pkg) @@ -2077,7 +2077,7 @@ (defun slime-set-package (package) (interactive (list (slime-read-package-name "Package: " (slime-find-buffer-package)))) - (message "*package*: %s" (slime-eval `(swank:set-package package)))) + (message "*package*: %s" (slime-eval `(swank:set-package ,package)))) (defun slime-set-default-directory (directory) (interactive (list (read-file-name "Directory: " nil default-directory t))) @@ -2241,7 +2241,8 @@ (:file (funcall (if other-window #'find-file-other-window #'find-file) (plist-get source-location :filename)) - (goto-char (plist-get source-location :position))) + (goto-char (plist-get source-location :position)) + (forward-sexp) (backward-sexp)) (:stream (let ((info (plist-get source-location :info))) (cond ((and (consp info) (eq :emacs-buffer (car info))) @@ -2805,7 +2806,7 @@ (def-slime-test compile-defun (program subform) "Compile PROGRAM containing errors. -Confirm that SUBFORM is correclty located." +Confirm that SUBFORM is correctly located." '(("(defun :foo () (:bar))" (:bar)) ("(defun :foo () #\\space From dbarlow at common-lisp.net Fri Oct 17 01:38:41 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Thu, 16 Oct 2003 21:38:41 -0400 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5302 Modified Files: swank-sbcl.lisp Log Message: Transplanted Helmut's serve-event server to replace the existing thread-using server. SLIME now has no dependency on SB-THREAD Date: Thu Oct 16 21:38:41 2003 Author: dbarlow Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.5 slime/swank-sbcl.lisp:1.6 --- slime/swank-sbcl.lisp:1.5 Thu Oct 16 16:05:21 2003 +++ slime/swank-sbcl.lisp Thu Oct 16 21:38:41 2003 @@ -31,7 +31,6 @@ ;;; * Cross-referencing (nor is it likely, absent XREF port to SBCL) ;;; * testsuite can't find LOOP, reports bogus failure on some arglist lookups ;;; * eval-in-frame -;;; * M-. has an off-by-two (character positions) error ;;; * A slime command to load an asdf system. Note that this might involve ;;; compiling/loading files that Emacs has no buffers for ;;; * Dealing with multiple threads @@ -50,6 +49,52 @@ ;;; TCP Server + +(defun create-swank-server (port &key reuse-address) + "Create a SWANK TCP server." + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (when reuse-address + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)) + (setf (sb-bsd-sockets:non-blocking-mode socket) t) + (sb-bsd-sockets:socket-bind socket #(127 0 0 1) port) + (sb-bsd-sockets:socket-listen socket 5) + (sb-sys:add-fd-handler + (sb-bsd-sockets:socket-file-descriptor socket) + :input (lambda (fd) + (declare (ignore fd)) + (accept-connection socket))))) + +(defun accept-connection (server-socket) + "Accept a SWANK TCP connection on SOCKET." + (let* ((socket (sb-bsd-sockets:socket-accept server-socket)) + (stream (sb-bsd-sockets:socket-make-stream + socket :input t :output t :element-type 'unsigned-byte))) + (sb-sys:add-fd-handler + (sb-bsd-sockets:socket-file-descriptor socket) + :input (lambda (fd) + (declare (ignore fd)) + (serve-request stream))))) + +(defun serve-request (*emacs-io*) + "Read and process a request from a SWANK client. +The request is read from the socket as a sexp and then evaluated." + (let* ((completed nil) + (*slime-output* (make-instance 'slime-output-stream))) + (let ((condition (catch 'serve-request-catcher + (read-from-emacs) + (setq completed t)))) + (unless completed + (when *swank-debug-p* + (format *debug-io* + "~&;; Connection to Emacs lost.~%;; [~A]~%" condition)) + (sb-sys:invalidate-descriptor (sb-sys:fd-stream-fd *emacs-io*)) + (close *emacs-io*))))) + + +#| + ;; The Swank backend runs in a separate thread and simply blocks on ;; its TCP port while waiting for forms to evaluate. @@ -109,6 +154,9 @@ (return)))))))) (format *terminal-io* "~&;; Swank: Closed connection: ~A~%" *emacs-io*) (close *emacs-io*))) +|# + + ;;; Redirecting Output to Emacs From dbarlow at common-lisp.net Fri Oct 17 01:39:02 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Thu, 16 Oct 2003 21:39:02 -0400 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5596 Modified Files: swank.lisp Log Message: Fix random typos Date: Thu Oct 16 21:39:02 2003 Author: dbarlow Index: slime/swank.lisp diff -u slime/swank.lisp:1.33 slime/swank.lisp:1.34 --- slime/swank.lisp:1.33 Thu Oct 16 17:03:57 2003 +++ slime/swank.lisp Thu Oct 16 21:39:02 2003 @@ -69,7 +69,7 @@ (defun read-next-form () "Read the next Slime request from *EMACS-IO* and return an -S-expression to be evaulated to handle the request. If an error +S-expression to be evaluated to handle the request. If an error occurs during parsing, it will be noted and control will be tranferred back to the main request handling loop." (handler-case From dbarlow at common-lisp.net Fri Oct 17 02:08:50 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Thu, 16 Oct 2003 22:08:50 -0400 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29920 Modified Files: swank.lisp Log Message: Ok. There is a mistake in the local vars part in swank.lisp. ;;; End needs a colon at the end to match the colon on ;;; Local Variables: Date: Thu Oct 16 22:08:50 2003 Author: dbarlow Index: slime/swank.lisp diff -u slime/swank.lisp:1.34 slime/swank.lisp:1.35 --- slime/swank.lisp:1.34 Thu Oct 16 21:39:02 2003 +++ slime/swank.lisp Thu Oct 16 22:08:50 2003 @@ -280,4 +280,4 @@ ;;; Local Variables: ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) -;;; End +;;; End: From lgorrie at common-lisp.net Fri Oct 17 17:42:39 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 17 Oct 2003 13:42:39 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29677 Modified Files: slime.el Log Message: (slime-net-connect): Check that 'set-process-coding-system' is fbound before calling it. This is needed in the XEmacs I built from sources. Date: Fri Oct 17 13:42:38 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.37 slime/slime.el:1.38 --- slime/slime.el:1.37 Thu Oct 16 21:38:01 2003 +++ slime/slime.el Fri Oct 17 13:42:38 2003 @@ -562,8 +562,9 @@ (set-process-buffer slime-net-process buffer) (set-process-filter slime-net-process 'slime-net-filter) (set-process-sentinel slime-net-process 'slime-net-sentinel) - (set-process-coding-system slime-net-process - 'no-conversion 'no-conversion)) + (when (fboundp 'set-process-coding-system) + (set-process-coding-system slime-net-process + 'no-conversion 'no-conversion))) slime-net-process) (file-error () nil))) From lgorrie at common-lisp.net Fri Oct 17 17:42:52 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 17 Oct 2003 13:42:52 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29717 Modified Files: ChangeLog Log Message: Date: Fri Oct 17 13:42:52 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.35 slime/ChangeLog:1.36 --- slime/ChangeLog:1.35 Thu Oct 16 21:37:33 2003 +++ slime/ChangeLog Fri Oct 17 13:42:52 2003 @@ -1,3 +1,9 @@ +2003-10-17 Luke Gorrie + + * slime.el (slime-net-connect): Check that + `set-process-coding-system' is fbound before calling it. This is + needed in the XEmacs I built from sources. + 2003-10-17 Daniel Barlow * swank-sbcl.lisp: Transplanted Helmut's serve-event server to From jbielman at common-lisp.net Fri Oct 17 19:09:16 2003 From: jbielman at common-lisp.net (James Bielman) Date: Fri, 17 Oct 2003 15:09:16 -0400 Subject: [slime-cvs] CVS update: slime/swank-loader.lisp slime/ChangeLog slime/slime.el slime/swank-cmucl.lisp slime/swank-openmcl.lisp slime/swank-sbcl.lisp slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11290 Modified Files: ChangeLog slime.el swank-cmucl.lisp swank-openmcl.lisp swank-sbcl.lisp swank.lisp Added Files: swank-loader.lisp Log Message: Many fixes for the OpenMCL port: * swank.lisp (apropos-symbols): Change back to using the standard 2-argument APROPOS-LIST and check symbols explicitly when EXTERNAL-ONLY is true. Move loading of sys-dependent backend code into 'swank-loader'. * swank-sbcl.lisp: Moved declarations of *PREVIOUS-COMPILER-CONDITION* into 'swank.lisp' to kill warnings about undefined variables. * swank-openmcl.lisp (handle-compiler-warning): Use source position instead of function name for warning locations. (swank-compile-string): Compile into a temporary file instead of using COMPILE so finding warning positions works when using C-c C-c. (compute-backtrace): Don't display frames without a function. (apropos-list-for-emacs): Implement APROPOS. (who-calls): Implement WHO-CALLS. (completions): Implement COMPLETIONS. Use NIL instead of zero so FRESH-LINE does the right thing. * slime.el (slime-maybe-compile-swank): Removed function---compile the backend using 'swank-loader.lisp' instead. (slime-backend): Changed default backend to 'slime-loader'. (slime-lisp-binary-extension): Deleted as this is no longer needed. * swank-loader.lisp: New file. Date: Fri Oct 17 15:09:15 2003 Author: jbielman Index: slime/ChangeLog diff -u slime/ChangeLog:1.36 slime/ChangeLog:1.37 --- slime/ChangeLog:1.36 Fri Oct 17 13:42:52 2003 +++ slime/ChangeLog Fri Oct 17 15:09:14 2003 @@ -1,3 +1,30 @@ +2003-10-17 James Bielman + + * swank.lisp (apropos-symbols): Change back to using the standard + 2-argument APROPOS-LIST and check symbols explicitly when + EXTERNAL-ONLY is true. + Move loading of sys-dependent backend code into 'swank-loader'. + + * swank-sbcl.lisp: Moved declarations of *PREVIOUS-COMPILER-CONDITION* + into 'swank.lisp' to kill warnings about undefined variables. + + * swank-openmcl.lisp (handle-compiler-warning): Use source position + instead of function name for warning locations. + (swank-compile-string): Compile into a temporary file instead of + using COMPILE so finding warning positions works when using C-c C-c. + (compute-backtrace): Don't display frames without a function. + (apropos-list-for-emacs): Implement APROPOS. + (who-calls): Implement WHO-CALLS. + (completions): Implement COMPLETIONS. + Use NIL instead of zero so FRESH-LINE does the right thing. + + * slime.el (slime-maybe-compile-swank): Removed function---compile + the backend using 'swank-loader.lisp' instead. + (slime-backend): Changed default backend to 'slime-loader'. + (slime-lisp-binary-extension): Deleted as this is no longer needed. + + * swank-loader.lisp: New file. + 2003-10-17 Luke Gorrie * slime.el (slime-net-connect): Check that Index: slime/slime.el diff -u slime/slime.el:1.38 slime/slime.el:1.39 --- slime/slime.el:1.38 Fri Oct 17 13:42:38 2003 +++ slime/slime.el Fri Oct 17 15:09:14 2003 @@ -76,10 +76,7 @@ "Number of times to try connecting to the Swank server before aborting. Nil means never give up.") -(defvar slime-lisp-binary-extension ".x86f" - "Filename extension for Lisp object files.") - -(defvar slime-backend "swank" +(defvar slime-backend "swank-loader" "The name of the Lisp file implementing the Swank server.") (make-variable-buffer-local @@ -506,28 +503,11 @@ (defun slime-start-swank-server () "Start a Swank server on the inferior lisp." - (slime-maybe-compile-swank) (comint-proc-query (inferior-lisp-proc) (format "(load %S)\n" (concat slime-path slime-backend))) (comint-proc-query (inferior-lisp-proc) (format "(swank:start-server %S)\n" slime-swank-port))) - -(defun slime-maybe-compile-swank () - (let ((source (concat slime-path slime-backend ".lisp")) - (binary (concat slime-path slime-backend slime-lisp-binary-extension))) - (flet ((compile-swank () (comint-proc-query - (inferior-lisp-proc) - (format "(compile-file %S)\n" source)))) - (when (or (and (not (file-exists-p binary)) - (or slime-dont-prompt - (y-or-n-p "\ -The CMUCL support library (Swank) is not compiled. Compile now? "))) - (and (file-newer-than-file-p source binary) - (or slime-dont-prompt - (y-or-n-p "\ -Your Swank binary is older than the source. Recompile now? ")))) - (compile-swank))))) (defun slime-fetch-features-list () "Fetch and remember the *FEATURES* of the inferior lisp." Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.6 slime/swank-cmucl.lisp:1.7 --- slime/swank-cmucl.lisp:1.6 Thu Oct 16 17:03:37 2003 +++ slime/swank-cmucl.lisp Fri Oct 17 15:09:14 2003 @@ -130,12 +130,6 @@ ;;;; Compilation Commands -(defvar *previous-compiler-condition* nil - "Used to detect duplicates.") - -(defvar *previous-context* nil - "Used for compiler warnings without context.") - (defvar *buffername*) (defvar *buffer-offset*) Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.7 slime/swank-openmcl.lisp:1.8 --- slime/swank-openmcl.lisp:1.7 Thu Oct 16 17:03:37 2003 +++ slime/swank-openmcl.lisp Fri Oct 17 15:09:14 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.7 2003/10/16 21:03:37 lgorrie Exp $ +;;; $Id: swank-openmcl.lisp,v 1.8 2003/10/17 19:09:14 jbielman Exp $ ;;; ;;; @@ -21,6 +21,11 @@ ;;; 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. @@ -30,18 +35,18 @@ ;;; * 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: ;;; -;;; * Compiler warnings are trapped and sent to Emacs. The elisp code -;;; attempts to place the warnings on the correct defun by doing -;;; regular expression searches. Does not work in all cases. +;;; * 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. -;;; * Symbol completion. -;;; * Apropos. ;;; * Due to unimplementation functionality the test suite does not ;;; run correctly (it hangs upon entering the debugger). ;;; @@ -62,8 +67,6 @@ "Create the TCP server and accept connections in a new thread." (let ((server-socket (ccl:make-socket :connect :passive :local-port port :reuse-address reuse-address))) - (format *terminal-io* "~&;; Swank: Accepting connections on port ~D.~%" - port) (loop (let ((socket (ccl:accept-connection server-socket :wait t))) (ccl:process-run-function @@ -104,7 +107,7 @@ (write-char char (slime-output-stream-buffer stream))) (defmethod ccl:stream-line-column ((stream slime-output-stream)) - 0) + nil) (defmethod ccl:stream-force-output ((stream slime-output-stream)) (send-to-emacs `(:read-output ,(get-output-stream-string @@ -117,7 +120,6 @@ (defvar *swank-debugger-hook*) (defvar *swank-debugger-stack-frame*) -;;; XXX i hope this is correct for threads (defmethod ccl::application-error :before (application condition error-pointer) (declare (ignore application condition)) (setq *swank-debugger-stack-frame* error-pointer)) @@ -143,43 +145,53 @@ ;;; Compilation -(defun condition-function-name (condition) - "Return the function name as a symbol from a compiler condition." - (symbol-name (car (ccl::compiler-warning-function-name - condition)))) +(defvar *buffer-offset*) + +(defun condition-source-position (condition) + "Return the position in the source file of a compiler condition." + (+ 1 *buffer-offset* (ccl::compiler-warning-stream-position condition))) (defun handle-compiler-warning (condition) "Construct a compiler note for Emacs from a compiler warning condition." - (describe (car (ccl::compiler-warning-function-name condition))) (push (list :position nil - :function-name (condition-function-name condition) :source-path nil :filename (ccl::compiler-warning-file-name condition) :severity :warning :message (format nil "~A" condition) :context nil - :buffername nil - :buffer-offset 0) - *compiler-notes*)) + :buffername 'anything + :buffer-offset (condition-source-position condition)) + *compiler-notes*) + (muffle-warning condition)) (defun call-trapping-compilation-notes (fn) (handler-bind ((ccl::compiler-warning #'handle-compiler-warning)) (funcall fn))) +(defun temp-file-name () + (ccl:%get-cstring (#_tmpnam (ccl:%null-ptr)))) + (defslimefun swank-compile-string (string buffer start) - (declare (ignore buffer start)) - (call-with-compilation-hooks - (lambda () - (let ((*package* *buffer-package*)) - (eval (from-string - (format nil "(funcall (compile nil '(lambda () ~A)))" - string))))))) + (declare (ignore buffer)) + (let ((*buffer-offset* start) + (*package* *buffer-package*) + (filename (temp-file-name))) + (call-with-compilation-hooks + (lambda () + (unwind-protect + (progn + (with-open-file (s filename :direction :output :if-exists :error) + (write-string string s)) + (let ((binary-filename (compile-file filename :load t))) + (delete-file binary-filename))) + (delete-file filename)))))) (defslimefun swank-compile-file (filename load) - (call-with-compilation-hooks - (lambda () - (compile-file filename :load load)))) + (let ((*buffer-offset* 0)) + (call-with-compilation-hooks + (lambda () + (compile-file filename :load load))))) ;;; Debugging @@ -243,27 +255,25 @@ (defun compute-backtrace (start end &key (start-frame (ccl::%get-frame-ptr))) (let ((tcr (ccl::%current-tcr)) (result) + (frame-number 0) (total 0)) (do* ((p start-frame (ccl::parent-frame p tcr)) - (frame-number 0 (1+ frame-number)) (q (ccl::last-frame-ptr tcr))) ((or (null p) (eq p q) (ccl::%stack< q p tcr)) (values)) (declare (fixnum frame-number)) (progn (multiple-value-bind (lfun pc) (ccl::cfp-lfun p) - (incf total) - (if (and (>= frame-number start) (< frame-number end)) - (push (list frame-number - (format nil "~D: (~A~A)" + (declare (ignore pc)) + (when lfun + (incf total) + (if (and (>= frame-number start) (< frame-number end)) + (push (list frame-number + (format nil "~D: (~A)" frame-number - (if lfun - (ccl::%lfun-name-string lfun) - "#") - (if lfun - (frame-parameters p tcr lfun pc) - ""))) - result))))) + (ccl::%lfun-name-string lfun))) + result)) + (incf frame-number))))) (values (nreverse result) total))) (defslimefun backtrace-for-emacs (start end) @@ -300,12 +310,91 @@ (defslimefun describe-class (symbol-name) (print-description-to-string (find-class (from-string symbol-name) nil))) -(defslimefun-unimplemented apropos-list-for-emacs (name &optional - external-only - package)) +(defun briefly-describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result '())) + (labels ((first-line (string) + (let ((pos (position #\newline string))) + (if (null pos) string (subseq string 0 pos)))) + (doc (kind &optional (sym symbol)) + (let ((string (documentation sym kind))) + (if string + (first-line string) + :not-documented))) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :setf (let ((setf-function-name (ccl::setf-function-spec-name + `(setf ,symbol)))) + (when (fboundp setf-function-name) + (doc 'function setf-function-name)))) +;; (maybe-push +;; :type (if (ext:info type kind symbol) +;; (doc 'type))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + (if result + (list* :designator (to-string symbol) result))))) + +(defslimefun apropos-list-for-emacs (name &optional external-only package) + "Make an apropos search for Emacs. +The result is a list of property lists." + (mapcan (listify #'briefly-describe-symbol-for-emacs) + (sort (apropos-symbols name external-only package) + #'present-symbol-before-p))) + +(defun listify (f) + "Return a function like F, but which returns any non-null value +wrapped in a list." + (lambda (x) + (let ((y (funcall f x))) + (and y (list y))))) + +(defun present-symbol-before-p (a b) + "Return true if A belongs before B in a printed summary of symbols. +Sorted alphabetically by package name and then symbol name, except +that symbols accessible in the current package go first." + (flet ((accessible (s) + (find-symbol (symbol-name s) *buffer-package*))) + (let ((pa (symbol-package a)) + (pb (symbol-package b))) + (cond ((or (eq pa pb) + (and (accessible a) (accessible b))) + (string< (symbol-name a) (symbol-name b))) + ((accessible a) t) + ((accessible b) nil) + (t + (string< (package-name pa) (package-name pb))))))) ;;; Tracing and Disassembly +(defslimefun who-calls (symbol-name) + (let ((callers (ccl::callers symbol-name)) + (result (make-hash-table :test 'equalp)) + (list nil)) + (dolist (caller callers) + (let ((source-info (ccl::%source-files caller))) + (when (atom source-info) + (let ((filename (namestring (truename source-info))) + ;; This is clearly not the real source path but it will + ;; get us into the file at least... + (source-path '(0))) + (push (list (string caller) source-path) + (gethash filename result)))))) + (maphash #'(lambda (k v) + (push (cons k (list v)) list)) + result) + list)) + (defslimefun-unimplemented who-references (symbol-name package-name)) (defslimefun-unimplemented who-binds (symbol-name package-name)) (defslimefun-unimplemented who-sets (symbol-name package-name)) @@ -316,7 +405,54 @@ ;;; Completion -(defslimefun-unimplemented completions (string default-package-name)) +(defslimefun completions (string default-package-name) + "Return a list of completions for a symbol designator STRING. + +The result is a list of strings. If STRING is package qualified the +result list will also be qualified. If string is non-qualified the +result strings are also not qualified and are considered relative to +DEFAULT-PACKAGE-NAME. All symbols accessible in the package are +considered." + (flet ((parse-designator (string) + (values (let ((pos (position #\: string :from-end t))) + (if pos (subseq string (1+ pos)) string)) + (let ((pos (position #\: string))) + (if pos (subseq string 0 pos) nil)) + (search "::" string)))) + (multiple-value-bind (name package-name internal) + (parse-designator string) + (let ((completions nil) + (package (find-package + (string-upcase (cond ((equal package-name "") "KEYWORD") + (package-name) + (default-package-name)))))) + (when package + (do-symbols (symbol package) + (when (and (string-prefix-p name (symbol-name symbol)) + (or internal + (not package-name) + (symbol-external-p symbol))) + (push symbol completions)))) + (let ((*print-case* (if (find-if #'upper-case-p string) + :upcase :downcase)) + (*package* package)) + (mapcar (lambda (s) + (cond (internal (format nil "~A::~A" package-name s)) + (package-name (format nil "~A:~A" package-name s)) + (t (format nil "~A" s)))) + completions)))))) + +(defun symbol-external-p (s) + (multiple-value-bind (_ status) + (find-symbol (symbol-name s) (symbol-package s)) + (declare (ignore _)) + (eq status :external))) + +(defun string-prefix-p (s1 s2) + "Return true iff the string S1 is a prefix of S2. \(This includes +the case where S1 is equal to S2.)" + (and (<= (length s1) (length s2)) + (string-equal s1 s2 :end2 (length s1)))) ;;; Macroexpansion Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.6 slime/swank-sbcl.lisp:1.7 --- slime/swank-sbcl.lisp:1.6 Thu Oct 16 21:38:41 2003 +++ slime/swank-sbcl.lisp Fri Oct 17 15:09:14 2003 @@ -230,9 +230,6 @@ (defvar *buffername*) (defvar *buffer-offset*) -(defvar *previous-compiler-condition* nil - "Used to detect duplicates.") - (defun handle-notification-condition (condition) "Handle a condition caused by a compiler warning. This traps all compiler conditions at a lower-level than using Index: slime/swank.lisp diff -u slime/swank.lisp:1.35 slime/swank.lisp:1.36 --- slime/swank.lisp:1.35 Thu Oct 16 22:08:50 2003 +++ slime/swank.lisp Fri Oct 17 15:09:14 2003 @@ -13,14 +13,6 @@ (:nicknames "SWANK-IMPL") (:export #:start-server))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter swank::*sysdep-pathname* - (merge-pathnames (or #+cmu "swank-cmucl" - #+(and sbcl sb-thread) "swank-sbcl" - #+openmcl "swank-openmcl") - (or *compile-file-pathname* *load-pathname* - *default-pathname-defaults*)))) - (in-package :swank) (defvar *swank-io-package* @@ -179,6 +171,12 @@ ;;;; Compilation Commands. +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Used for compiler warnings without context.") + (defvar *compiler-notes* '() "List of compiler notes for the last compilation unit.") @@ -236,10 +234,14 @@ (defslimefun list-all-package-names () (mapcar #'package-name (list-all-packages))) + (defun apropos-symbols (string &optional external-only package) - "Return the symbols matching an apropos search." - ;; CMUCL used ext:map-apropos here, not sure why - (remove-if #'keywordp (apropos-list string package external-only))) + (remove-if (lambda (sym) + (or (keywordp sym) + (and external-only + (not (equal (symbol-package sym) *buffer-package*)) + (not (symbol-external-p sym))))) + (apropos-list string package))) (defun print-output-to-string (fn) (with-output-to-string (*standard-output*) @@ -271,12 +273,6 @@ (defslimefun disassemble-symbol (symbol-name) (print-output-to-string (lambda () (disassemble (from-string symbol-name))))) - - -;;;; now pull the per-backend stuff in -(eval-when (:compile-toplevel) (compile-file swank::*sysdep-pathname*)) -(eval-when (:load-toplevel :execute) (load swank::*sysdep-pathname*)) - ;;; Local Variables: ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) From lgorrie at common-lisp.net Fri Oct 17 19:45:28 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 17 Oct 2003 15:45:28 -0400 Subject: [slime-cvs] CVS update: slime/test.sh Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv32152 Modified Files: test.sh Log Message: When the test fails to complete, print "crashed" instead of reporting nonsense. Date: Fri Oct 17 15:45:27 2003 Author: lgorrie Index: slime/test.sh diff -u slime/test.sh:1.3 slime/test.sh:1.4 --- slime/test.sh:1.3 Thu Oct 16 18:56:37 2003 +++ slime/test.sh Fri Oct 17 15:45:27 2003 @@ -39,8 +39,11 @@ status=$? -if [ $status != 0 ]; then +if [ -f $results ]; then echo $status "test(s) failed." +else + # Tests crashed + echo crashed fi exit $status From lgorrie at common-lisp.net Fri Oct 17 19:45:59 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 17 Oct 2003 15:45:59 -0400 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv32258 Modified Files: swank-sbcl.lisp Log Message: Report style-warnings separately from notes (patch from Christopher Rhodes). Use REQUIRE to load sb-introspect instead of loading the source file (requires the sb-introspect library to be installed, which doesn't yet happen in the sourceforge-lagged SBCL anoncvs, but does in the real one). Date: Fri Oct 17 15:45:59 2003 Author: lgorrie Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.7 slime/swank-sbcl.lisp:1.8 --- slime/swank-sbcl.lisp:1.7 Fri Oct 17 15:09:14 2003 +++ slime/swank-sbcl.lisp Fri Oct 17 15:45:59 2003 @@ -40,9 +40,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (require 'sb-bsd-sockets) (use-package "SB-BSD-SOCKETS") - #+nil (require 'sb-introspect) - (load - "/home/dan/src/sourceforge/sbcl/contrib/sb-introspect/sb-introspect")) + (require 'sb-introspect)) (declaim (optimize (debug 3))) (in-package :swank) @@ -254,7 +252,8 @@ :source-path (current-compiler-error-source-path context) :severity (etypecase condition (sb-c:compiler-error :error) - (style-warning :note) + (sb-ext:compiler-note :note) + (style-warning :style-warning) (warning :warning)) :message (brief-compiler-message-for-emacs condition context) :buffername (if (boundp '*buffername*) *buffername*) @@ -290,6 +289,7 @@ (defun call-trapping-compilation-notes (fn) (handler-bind ((sb-c:compiler-error #'handle-notification-condition) + (sb-ext:compiler-note #'handle-notification-condition) (style-warning #'handle-notification-condition) (warning #'handle-notification-condition)) (funcall fn))) From lgorrie at common-lisp.net Fri Oct 17 19:47:58 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 17 Oct 2003 15:47:58 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv335 Modified Files: slime.el Log Message: (slime-style-warning-face): Added style-warnings, which are between a warning and a note in severity. (Patch from Christopher Rhodes). Date: Fri Oct 17 15:47:58 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.39 slime/slime.el:1.40 --- slime/slime.el:1.39 Fri Oct 17 15:09:14 2003 +++ slime/slime.el Fri Oct 17 15:47:57 2003 @@ -122,12 +122,21 @@ "Face for warnings from the compiler." :group 'slime) -(defface slime-note-face +(defface slime-style-warning-face '((((class color) (background light)) (:underline "brown")) (((class color) (background dark)) (:underline "gold")) (t (:underline t))) + "Face for style-warnings from the compiler." + :group 'slime) + +(defface slime-note-face + '((((class color) (background light)) + (:underline "brown4")) + (((class color) (background dark)) + (:underline "light goldenrod")) + (t (:underline t))) "Face for notes from the compiler." :group 'slime) @@ -995,16 +1004,24 @@ (slime-buffer-package) (slime-compilation-finished-continuation))) +(defun slime-note-count-string (severity count) + (format "%s %s%s" count severity (if (= count 1) "" "s"))) + (defun slime-show-note-counts (notes &optional secs) (loop for note in notes for severity = (plist-get note :severity) count (eq :error severity) into errors count (eq :warning severity) into warnings + count (eq :style-warning severity) into style-warnings count (eq :note severity) into notes finally (message - "Compilation finished: %s errors %s warnings %s notes%s" - errors warnings notes (if secs (format " [%s secs]" secs) "")))) + "Compilation finished: %s %s %s %s%s" + (slime-note-count-string "error" errors) + (slime-note-count-string "warning" warnings) + (slime-note-count-string "style-warning" style-warnings) + (slime-note-count-string "note" notes) + (if secs (format " [%s secs]" secs) "")))) (defun slime-compilation-finished (result buffer) (with-current-buffer buffer @@ -1060,7 +1077,7 @@ "Create an overlay representing a compiler note. The overlay has several properties: FACE - to underline the relevant text. - SEVERITY - for future reference, :NOTE, :WARNING, or :ERROR. + SEVERITY - for future reference, :NOTE, :STYLE-WARNING, :WARNING, or :ERROR. MOUSE-FACE - highlight the note when the mouse passes over. HELP-ECHO - a string describing the note, both for future reference and for display as a tooltip (due to the special @@ -1119,16 +1136,19 @@ (defun slime-severity-face (severity) "Return the name of the font-lock face representing SEVERITY." (ecase severity - (:error 'slime-error-face) - (:warning 'slime-warning-face) - (:note 'slime-note-face))) + (:error 'slime-error-face) + (:warning 'slime-warning-face) + (:style-warning 'slime-style-warning-face) + (:note 'slime-note-face))) (defun slime-most-severe (sev1 sev2) "Return the most servere of two conditions. -Severity is ordered as :NOTE < :WARNING < :ERROR." +Severity is ordered as :NOTE < :STYLE-WARNING < :WARNING < :ERROR." (if (or (eq sev1 :error) ; Well, not exactly Smullyan.. (and (eq sev1 :warning) - (not (eq sev2 :error)))) + (not (eq sev2 :error))) + (and (eq sev1 :style-warning) + (not (member sev2 '(:warning :error))))) sev1 sev2)) From lgorrie at common-lisp.net Fri Oct 17 19:48:16 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 17 Oct 2003 15:48:16 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv521 Modified Files: ChangeLog Log Message: Date: Fri Oct 17 15:48:15 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.37 slime/ChangeLog:1.38 --- slime/ChangeLog:1.37 Fri Oct 17 15:09:14 2003 +++ slime/ChangeLog Fri Oct 17 15:48:15 2003 @@ -1,3 +1,18 @@ +2003-10-17 Luke Gorrie + + * swank-sbcl.lisp: Report style-warnings separately from notes + (patch from Christopher Rhodes). Use REQUIRE to load sb-introspect + instead of loading the source file (requires the sb-introspect + library to be installed, which doesn't yet happen in the + sourceforge-lagged SBCL anoncvs, but does in the real one). + + * slime.el (slime-style-warning-face): Added style-warnings, which + are between a warning and a note in severity. (Patch from + Christopher Rhodes). + + * test.sh: When the test fails to complete, print "crashed" + instead of reporting nonsense. + 2003-10-17 James Bielman * swank.lisp (apropos-symbols): Change back to using the standard From lgorrie at common-lisp.net Fri Oct 17 19:49:05 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 17 Oct 2003 15:49:05 -0400 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv1825 Modified Files: swank.lisp Log Message: Date: Fri Oct 17 15:49:05 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.36 slime/swank.lisp:1.37 --- slime/swank.lisp:1.36 Fri Oct 17 15:09:14 2003 +++ slime/swank.lisp Fri Oct 17 15:49:05 2003 @@ -189,7 +189,7 @@ "Database of recorded compiler notes/warnings/erros (keyed by filename). Each value is a list of (LOCATION SEVERITY MESSAGE CONTEXT) lists. LOCATION is a position in the source code (integer or source path). - SEVERITY is one of :ERROR, :WARNING, and :NOTE. + SEVERITY is one of :ERROR, :WARNING, :STYLE-WARNING and :NOTE. MESSAGE is a string describing the note. CONTEXT is a string giving further details of where the error occured.") From lgorrie at common-lisp.net Fri Oct 17 19:55:48 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 17 Oct 2003 15:55:48 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4964 Modified Files: slime.el Log Message: (slime-post-command-hook): Check that we are connected before trying to process input. (slime-net-connect): Handle `network-error' condition for XEmacs 21.5. (Thanks Raymond Toy.) Date: Fri Oct 17 15:55:47 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.40 slime/slime.el:1.41 --- slime/slime.el:1.40 Fri Oct 17 15:47:57 2003 +++ slime/slime.el Fri Oct 17 15:55:47 2003 @@ -262,7 +262,8 @@ (setq slime-pre-command-actions nil)) (defun slime-post-command-hook () - (slime-process-available-input)) + (when (slime-connected-p) + (slime-process-available-input))) (defun slime-setup-command-hooks () "Setup a buffer-local `pre-command-hook' to call `slime-pre-command-hook'." @@ -555,7 +556,8 @@ (set-process-coding-system slime-net-process 'no-conversion 'no-conversion))) slime-net-process) - (file-error () nil))) + (file-error () nil) + (network-error () nil))) (defun slime-make-net-buffer (name) "Make a buffer suitable for a network process." From lgorrie at common-lisp.net Fri Oct 17 19:55:54 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 17 Oct 2003 15:55:54 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5004 Modified Files: ChangeLog Log Message: Date: Fri Oct 17 15:55:54 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.38 slime/ChangeLog:1.39 --- slime/ChangeLog:1.38 Fri Oct 17 15:48:15 2003 +++ slime/ChangeLog Fri Oct 17 15:55:54 2003 @@ -1,5 +1,10 @@ 2003-10-17 Luke Gorrie + * slime.el (slime-post-command-hook): Check that we are connected + before trying to process input. + (slime-net-connect): Handle `network-error' condition for XEmacs + 21.5. (Thanks Raymond Toy.) + * swank-sbcl.lisp: Report style-warnings separately from notes (patch from Christopher Rhodes). Use REQUIRE to load sb-introspect instead of loading the source file (requires the sb-introspect From heller at common-lisp.net Fri Oct 17 21:18:04 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 17 Oct 2003 17:18:04 -0400 Subject: [slime-cvs] CVS update: slime/swank.lisp slime/swank-cmucl.lisp slime/swank-openmcl.lisp slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15851 Modified Files: swank.lisp swank-cmucl.lisp swank-openmcl.lisp swank-sbcl.lisp Log Message: Move more stuff to swank.lisp. Date: Fri Oct 17 17:18:04 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.37 slime/swank.lisp:1.38 --- slime/swank.lisp:1.37 Fri Oct 17 15:49:05 2003 +++ slime/swank.lisp Fri Oct 17 17:18:04 2003 @@ -33,7 +33,6 @@ (defun start-server (&optional (port server-port)) "Start the Slime backend on TCP port `port'." (create-swank-server port :reuse-address t) - #+xref (setf c:*record-xref-info* t) (when *swank-debug-p* (format *debug-io* "~&;; Swank ready.~%"))) @@ -92,7 +91,7 @@ (defun prin1-to-string-for-emacs (object) (with-standard-io-syntax (let ((*print-case* :downcase) - (*print-readably* nil) + (*print-readably* t) (*print-pretty* nil) (*package* *swank-io-package*)) (prin1-to-string object)))) @@ -137,6 +136,14 @@ (error "Backend function ~A not implemented." ',fun)) (export ',fun :swank))) +(defvar *swank-debugger-condition*) +(defvar *swank-debugger-hook*) + +(defun swank-debugger-hook (condition hook) + (let ((*swank-debugger-condition* condition) + (*swank-debugger-hook* hook)) + (sldb-loop))) + (defslimefun eval-string (string buffer-package) (let ((*debugger-hook* #'swank-debugger-hook)) (let (ok result) @@ -153,8 +160,24 @@ (force-output) (format nil "~{~S~^, ~}" values))) -;;; this was unimplemented in -openmcl, anyone know why? -;;; ditto interactive-eval-region +(defslimefun interactive-eval-region (string) + (let ((*package* *buffer-package*)) + (with-input-from-string (stream string) + (loop for form = (read stream nil stream) + until (eq form stream) + for result = (multiple-value-list (eval form)) + do (force-output) + finally (return (format nil "~{~S~^, ~}" result)))))) + +(defslimefun re-evaluate-defvar (form) + (let ((*package* *buffer-package*)) + (let ((form (read-from-string form))) + (destructuring-bind (dv name &optional value doc) form + (declare (ignore value doc)) + (assert (eq dv 'defvar)) + (makunbound name) + (prin1-to-string (eval form)))))) + (defslimefun pprint-eval (string) (let ((*package* *buffer-package*)) (let ((value (eval (read-from-string string)))) @@ -226,8 +249,8 @@ (defun call-with-compilation-hooks (fn) (multiple-value-bind (result usecs) (with-trapping-compilation-notes () - (clear-compiler-notes) - (measure-time-interval fn)) + (clear-compiler-notes) + (measure-time-interval fn)) (list (to-string result) (format nil "~,2F" (/ usecs 1000000.0))))) @@ -273,6 +296,96 @@ (defslimefun disassemble-symbol (symbol-name) (print-output-to-string (lambda () (disassemble (from-string symbol-name))))) + +;;; Completion + +(defslimefun completions (string default-package-name) + "Return a list of completions for a symbol designator STRING. + +The result is a list of strings. If STRING is package qualified the +result list will also be qualified. If string is non-qualified the +result strings are also not qualified and are considered relative to +DEFAULT-PACKAGE-NAME. All symbols accessible in the package are +considered." + (flet ((parse-designator (string) + (values (let ((pos (position #\: string :from-end t))) + (if pos (subseq string (1+ pos)) string)) + (let ((pos (position #\: string))) + (if pos (subseq string 0 pos) nil)) + (search "::" string)))) + (multiple-value-bind (name package-name internal) (parse-designator string) + (let ((completions nil) + (package (find-package + (string-upcase (cond ((equal package-name "") "KEYWORD") + (package-name) + (default-package-name)))))) + (when package + (do-symbols (symbol package) + (when (and (string-prefix-p name (symbol-name symbol)) + (or internal + (not package-name) + (symbol-external-p symbol))) + (push symbol completions)))) + (let ((*print-case* (if (find-if #'upper-case-p string) + :upcase :downcase)) + (*package* package)) + (mapcar (lambda (s) + (cond (internal (format nil "~A::~A" package-name s)) + (package-name (format nil "~A:~A" package-name s)) + (t (format nil "~A" s)))) + completions)))))) + +(defun symbol-external-p (s) + (multiple-value-bind (_ status) + (find-symbol (symbol-name s) (symbol-package s)) + (declare (ignore _)) + (eq status :external))) + +(defun string-prefix-p (s1 s2) + "Return true iff the string S1 is a prefix of S2. +\(This includes the case where S1 is equal to S2.)" + (and (<= (length s1) (length s2)) + (string-equal s1 s2 :end2 (length s1)))) + +;;; Apropos + +(defslimefun apropos-list-for-emacs (name &optional external-only package) + "Make an apropos search for Emacs. +The result is a list of property lists." + (mapcan (listify #'briefly-describe-symbol-for-emacs) + (sort (apropos-symbols name external-only package) + #'present-symbol-before-p))) + +(defun listify (f) + "Return a function like F, but which returns any non-null value +wrapped in a list." + (lambda (x) + (let ((y (funcall f x))) + (and y (list y))))) + +(defun present-symbol-before-p (a b) + "Return true if A belongs before B in a printed summary of symbols. +Sorted alphabetically by package name and then symbol name, except +that symbols accessible in the current package go first." + (flet ((accessible (s) + (find-symbol (symbol-name s) *buffer-package*))) + (let ((pa (symbol-package a)) + (pb (symbol-package b))) + (cond ((or (eq pa pb) + (and (accessible a) (accessible b))) + (string< (symbol-name a) (symbol-name b))) + ((accessible a) t) + ((accessible b) nil) + (t + (string< (package-name pa) (package-name pb))))))) + +;;; + +(defslimefun untrace-all () + (untrace)) + +(defslimefun load-file (filename) + (load filename)) ;;; Local Variables: ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.7 slime/swank-cmucl.lisp:1.8 --- slime/swank-cmucl.lisp:1.7 Fri Oct 17 15:09:14 2003 +++ slime/swank-cmucl.lisp Fri Oct 17 17:18:04 2003 @@ -14,6 +14,7 @@ (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK))))) (set-fd-non-blocking (sys:fd-stream-fd sys:*stdin*)) +(setf c:*record-xref-info* t) ;;; TCP Server. @@ -93,33 +94,7 @@ (condition (c) (throw 'serve-request-catcher c)))) -;;; Asynchronous eval - -(defvar *swank-debugger-condition*) -(defvar *swank-debugger-hook*) - -(defun swank-debugger-hook (condition hook) - (let ((*swank-debugger-condition* condition) - (*swank-debugger-hook* hook)) - (sldb-loop))) - -(defslimefun interactive-eval-region (string) - (let ((*package* *buffer-package*)) - (with-input-from-string (stream string) - (loop for form = (read stream nil stream) - until (eq form stream) - for result = (multiple-value-list (eval form)) - do (force-output) - finally (return (format nil "~{~S~^, ~}" result)))))) - -(defslimefun re-evaluate-defvar (form) - (let ((*package* *buffer-package*)) - (let ((form (read-from-string form))) - (destructuring-bind (dv name &optional value doc) form - (declare (ignore value doc)) - (assert (eq dv 'defvar)) - (makunbound name) - (prin1-to-string (eval form)))))) +;;; (defslimefun set-default-directory (directory) (setf (ext:default-directory) (namestring directory)) @@ -433,56 +408,6 @@ (defslimefun list-callees (symbol-name) (stringify-function-name-list (function-callees (from-string symbol-name)))) -;;; - -(defslimefun completions (string default-package-name) - "Return a list of completions for a symbol designator STRING. - -The result is a list of strings. If STRING is package qualified the -result list will also be qualified. If string is non-qualified the -result strings are also not qualified and are considered relative to -DEFAULT-PACKAGE-NAME. All symbols accessible in the package are -considered." - (flet ((parse-designator (string) - (values (let ((pos (position #\: string :from-end t))) - (if pos (subseq string (1+ pos)) string)) - (let ((pos (position #\: string))) - (if pos (subseq string 0 pos) nil)) - (search "::" string)))) - (multiple-value-bind (name package-name internal) (parse-designator string) - (let ((completions nil) - (package (find-package - (string-upcase (cond ((equal package-name "") "KEYWORD") - (package-name) - (default-package-name)))))) - (when package - (do-symbols (symbol package) - (when (and (string-prefix-p name (symbol-name symbol)) - (or internal - (not package-name) - (symbol-external-p symbol))) - (push symbol completions)))) - (let ((*print-case* (if (find-if #'upper-case-p string) - :upcase :downcase)) - (*package* package)) - (mapcar (lambda (s) - (cond (internal (format nil "~A::~A" package-name s)) - (package-name (format nil "~A:~A" package-name s)) - (t (format nil "~A" s)))) - completions)))))) - -(defun symbol-external-p (s) - (multiple-value-bind (_ status) - (find-symbol (symbol-name s) (symbol-package s)) - (declare (ignore _)) - (eq status :external))) - -(defun string-prefix-p (s1 s2) - "Return true iff the string S1 is a prefix of S2. -\(This includes the case where S1 is equal to S2.)" - (and (<= (length s1) (length s2)) - (string-equal s1 s2 :end2 (length s1)))) - ;;;; Definitions (defvar *debug-definition-finding* nil @@ -601,38 +526,6 @@ (if result (list* :designator (to-string symbol) result))))) -(defslimefun apropos-list-for-emacs (name &optional external-only package) - "Make an apropos search for Emacs. -The result is a list of property lists." - (mapcan (listify #'briefly-describe-symbol-for-emacs) - (sort (apropos-symbols name external-only package) - #'present-symbol-before-p))) - -(defun listify (f) - "Return a function like F, but which returns any non-null value -wrapped in a list." - (lambda (x) - (let ((y (funcall f x))) - (and y (list y))))) - -(defun present-symbol-before-p (a b) - "Return true if A belongs before B in a printed summary of symbols. -Sorted alphabetically by package name and then symbol name, except -that symbols accessible in the current package go first." - (flet ((accessible (s) - (find-symbol (symbol-name s) *buffer-package*))) - (let ((pa (symbol-package a)) - (pb (symbol-package b))) - (cond ((or (eq pa pb) - (and (accessible a) (accessible b))) - (string< (symbol-name a) (symbol-name b))) - ((accessible a) t) - ((accessible b) nil) - (t - (string< (package-name pa) (package-name pb))))))) - - - (defslimefun describe-setf-function (symbol-name) (print-description-to-string (or (ext:info setf inverse (from-string symbol-name)) @@ -666,24 +559,12 @@ (debug::trace-1 fname (debug::make-trace-info)) (format nil "~S is now traced." fname))))) -(defslimefun untrace-all () - (untrace)) - -(defslimefun load-file (filename) - (load filename)) - ;;; Debugging (defvar *sldb-level* 0) (defvar *sldb-stack-top*) (defvar *sldb-restarts*) - -(defslimefun ping (level) - (cond ((= level *sldb-level*) - *sldb-level*) - (t - (throw-to-toplevel)))) (defslimefun getpid () (unix:unix-getpid)) Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.8 slime/swank-openmcl.lisp:1.9 --- slime/swank-openmcl.lisp:1.8 Fri Oct 17 15:09:14 2003 +++ slime/swank-openmcl.lisp Fri Oct 17 17:18:04 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.8 2003/10/17 19:09:14 jbielman Exp $ +;;; $Id: swank-openmcl.lisp,v 1.9 2003/10/17 21:18:04 heller Exp $ ;;; ;;; @@ -116,22 +116,12 @@ ;;; Evaluation -(defvar *swank-debugger-condition*) -(defvar *swank-debugger-hook*) (defvar *swank-debugger-stack-frame*) (defmethod ccl::application-error :before (application condition error-pointer) (declare (ignore application condition)) (setq *swank-debugger-stack-frame* error-pointer)) -(defun swank-debugger-hook (condition hook) - (let ((*swank-debugger-condition* condition) - (*swank-debugger-hook* hook)) - (sldb-loop))) - -(defslimefun-unimplemented interactive-eval-region (string)) -(defslimefun-unimplemented re-evaluate-defvar (form)) - (defslimefun arglist-string (fname) (let ((*print-case* :downcase)) (multiple-value-bind (function condition) @@ -199,12 +189,6 @@ (defvar *sldb-stack-top*) (defvar *sldb-restarts*) -(defslimefun ping (level) - (cond ((= level *sldb-level*) - *sldb-level*) - (t - (throw-to-toplevel)))) - (defslimefun getpid () (ccl::getpid)) @@ -345,36 +329,6 @@ (if result (list* :designator (to-string symbol) result))))) -(defslimefun apropos-list-for-emacs (name &optional external-only package) - "Make an apropos search for Emacs. -The result is a list of property lists." - (mapcan (listify #'briefly-describe-symbol-for-emacs) - (sort (apropos-symbols name external-only package) - #'present-symbol-before-p))) - -(defun listify (f) - "Return a function like F, but which returns any non-null value -wrapped in a list." - (lambda (x) - (let ((y (funcall f x))) - (and y (list y))))) - -(defun present-symbol-before-p (a b) - "Return true if A belongs before B in a printed summary of symbols. -Sorted alphabetically by package name and then symbol name, except -that symbols accessible in the current package go first." - (flet ((accessible (s) - (find-symbol (symbol-name s) *buffer-package*))) - (let ((pa (symbol-package a)) - (pb (symbol-package b))) - (cond ((or (eq pa pb) - (and (accessible a) (accessible b))) - (string< (symbol-name a) (symbol-name b))) - ((accessible a) t) - ((accessible b) nil) - (t - (string< (package-name pa) (package-name pb))))))) - ;;; Tracing and Disassembly (defslimefun who-calls (symbol-name) @@ -402,57 +356,6 @@ (defslimefun-unimplemented find-fdefinition (symbol-name package-name)) (defslimefun-unimplemented function-source-location-for-emacs (fname)) - -;;; Completion - -(defslimefun completions (string default-package-name) - "Return a list of completions for a symbol designator STRING. - -The result is a list of strings. If STRING is package qualified the -result list will also be qualified. If string is non-qualified the -result strings are also not qualified and are considered relative to -DEFAULT-PACKAGE-NAME. All symbols accessible in the package are -considered." - (flet ((parse-designator (string) - (values (let ((pos (position #\: string :from-end t))) - (if pos (subseq string (1+ pos)) string)) - (let ((pos (position #\: string))) - (if pos (subseq string 0 pos) nil)) - (search "::" string)))) - (multiple-value-bind (name package-name internal) - (parse-designator string) - (let ((completions nil) - (package (find-package - (string-upcase (cond ((equal package-name "") "KEYWORD") - (package-name) - (default-package-name)))))) - (when package - (do-symbols (symbol package) - (when (and (string-prefix-p name (symbol-name symbol)) - (or internal - (not package-name) - (symbol-external-p symbol))) - (push symbol completions)))) - (let ((*print-case* (if (find-if #'upper-case-p string) - :upcase :downcase)) - (*package* package)) - (mapcar (lambda (s) - (cond (internal (format nil "~A::~A" package-name s)) - (package-name (format nil "~A:~A" package-name s)) - (t (format nil "~A" s)))) - completions)))))) - -(defun symbol-external-p (s) - (multiple-value-bind (_ status) - (find-symbol (symbol-name s) (symbol-package s)) - (declare (ignore _)) - (eq status :external))) - -(defun string-prefix-p (s1 s2) - "Return true iff the string S1 is a prefix of S2. \(This includes -the case where S1 is equal to S2.)" - (and (<= (length s1) (length s2)) - (string-equal s1 s2 :end2 (length s1)))) ;;; Macroexpansion Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.8 slime/swank-sbcl.lisp:1.9 --- slime/swank-sbcl.lisp:1.8 Fri Oct 17 15:45:59 2003 +++ slime/swank-sbcl.lisp Fri Oct 17 17:18:04 2003 @@ -177,36 +177,7 @@ ;;; Utilities -(defvar *swank-debugger-condition*) (defvar *swank-debugger-stack-frame*) -(defvar *swank-debugger-hook*) - -(defun swank-debugger-hook (condition hook) - (let ((*swank-debugger-condition* condition) - (*swank-debugger-hook* hook)) - (sldb-loop))) - -;;; this looks portable, but why no openmcl support? -(defslimefun interactive-eval-region (string) - (let ((*package* *buffer-package*)) - (with-input-from-string (stream string) - (loop for form = (read stream nil stream) - until (eq form stream) - for result = (multiple-value-list (eval form)) - do (force-output) - finally (return (format nil "~{~S~^, ~}" result)))))) - -(defslimefun re-evaluate-defvar (form) - (let ((*package* *buffer-package*)) - (let ((form (read-from-string form))) - (destructuring-bind (dv name &optional value doc) form - (declare (ignore value doc)) - (assert (eq dv 'defvar) (form) - "Can't parse ~S as a ~S form" form 'defvar) - (makunbound name) - (prin1-to-string (eval form)))))) - - ;;; adapted from cmucl (defslimefun set-default-directory (directory) @@ -338,56 +309,6 @@ (and (every #'< path1 path2) (< (length path1) (length path2)))) -(defslimefun completions (string default-package-name) - "Return a list of completions for a symbol designator STRING. - -The result is a list of strings. If STRING is package qualified the -result list will also be qualified. If string is non-qualified the -result strings are also not qualified and are considered relative to -DEFAULT-PACKAGE-NAME. All symbols accessible in the package are -considered." - (flet ((parse-designator (string) - (values (let ((pos (position #\: string :from-end t))) - (if pos (subseq string (1+ pos)) string)) - (let ((pos (position #\: string))) - (if pos (subseq string 0 pos) nil)) - (search "::" string)))) - (multiple-value-bind (name package-name internal) (parse-designator string) - (let ((completions nil) - (package (find-package - (string-upcase (cond ((equal package-name "") "KEYWORD") - (package-name) - (default-package-name)))))) - (when package - (do-symbols (symbol package) - (when (and (string-prefix-p name (symbol-name symbol)) - (or internal - (not package-name) - (symbol-external-p symbol))) - (push symbol completions)))) - (let ((*print-case* (if (find-if #'upper-case-p string) - :upcase :downcase)) - (*package* package)) - (mapcar (lambda (s) - (cond (internal (format nil "~A::~A" package-name s)) - (package-name (format nil "~A:~A" package-name s)) - (t (format nil "~A" s)))) - completions)))))) - -(defun symbol-external-p (s) - (multiple-value-bind (_ status) - (find-symbol (symbol-name s) (symbol-package s)) - (declare (ignore _)) - (eq status :external))) - -(defun string-prefix-p (s1 s2) - "Return true iff the string S1 is a prefix of S2. -\(This includes the case where S1 is equal to S2.)" - (and (<= (length s1) (length s2)) - (string-equal s1 s2 :end2 (length s1)))) - - - ;;;; Definitions (defvar *debug-definition-finding* nil @@ -475,38 +396,6 @@ (if result (list* :designator (to-string symbol) result))))) - -(defslimefun apropos-list-for-emacs (name &optional external-only package) - "Make an apropos search for Emacs. -The result is a list of property lists." - (mapcan (listify #'briefly-describe-symbol-for-emacs) - (sort (apropos-symbols name external-only package) - #'present-symbol-before-p))) - -(defun listify (f) - "Return a function like F, but which returns any non-null value -wrapped in a list." - (lambda (x) - (let ((y (funcall f x))) - (and y (list y))))) - -(defun present-symbol-before-p (a b) - "Return true if A belongs before B in a printed summary of symbols. -Sorted alphabetically by package name and then symbol name, except -that symbols accessible in the current package go first." - (flet ((accessible (s) - (find-symbol (symbol-name s) *buffer-package*))) - (let ((pa (symbol-package a)) - (pb (symbol-package b))) - (cond ((or (eq pa pb) - (and (accessible a) (accessible b))) - (string< (symbol-name a) (symbol-name b))) - ((accessible a) t) - ((accessible b) nil) - (t - (string< (package-name pa) (package-name pb))))))) - - (defslimefun describe-setf-function (symbol-name) (print-description-to-string `(setf ,(from-string symbol-name)))) @@ -536,26 +425,12 @@ (sb-debug::trace-1 fname (sb-debug::make-trace-info)) (format nil "~S is now traced." fname))))) -(defslimefun untrace-all () - (untrace)) - - - -(defslimefun load-file (filename) - (load filename)) - ;;; Debugging (defvar *sldb-level* 0) (defvar *sldb-stack-top*) (defvar *sldb-restarts*) - -(defslimefun ping (level) - (cond ((= level *sldb-level*) - *sldb-level*) - (t - (throw-to-toplevel)))) (defslimefun getpid () (sb-unix:unix-getpid)) From heller at common-lisp.net Fri Oct 17 21:19:47 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 17 Oct 2003 17:19:47 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17368 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Oct 17 17:19:47 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.39 slime/ChangeLog:1.40 --- slime/ChangeLog:1.39 Fri Oct 17 15:55:54 2003 +++ slime/ChangeLog Fri Oct 17 17:19:47 2003 @@ -1,3 +1,8 @@ +2003-10-17 Helmut Eller + + * swank.lisp, swank-sbcl.lisp, swank-openmcl.lisp, + swank-cmucl.lisp: Move more stuff to swank.lisp. + 2003-10-17 Luke Gorrie * slime.el (slime-post-command-hook): Check that we are connected From jbielman at common-lisp.net Sat Oct 18 05:06:45 2003 From: jbielman at common-lisp.net (James Bielman) Date: Sat, 18 Oct 2003 01:06:45 -0400 Subject: [slime-cvs] CVS update: slime/swank-loader.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12828 Modified Files: swank-loader.lisp Log Message: (compile-files-if-needed-serially): Be a little more verbose when compiling files. Date: Sat Oct 18 01:06:45 2003 Author: jbielman Index: slime/swank-loader.lisp diff -u slime/swank-loader.lisp:1.1 slime/swank-loader.lisp:1.2 --- slime/swank-loader.lisp:1.1 Fri Oct 17 15:09:14 2003 +++ slime/swank-loader.lisp Sat Oct 18 01:06:44 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-loader.lisp,v 1.1 2003/10/17 19:09:14 jbielman Exp $ +;;; $Id: swank-loader.lisp,v 1.2 2003/10/18 05:06:44 jbielman Exp $ ;;; (defpackage :swank-loader @@ -47,6 +47,7 @@ (when (or needs-recompile (not (probe-file binary-pathname)) (file-newer-p source-pathname binary-pathname)) + (format t "~&;; Compiling ~A...~%" source-pathname) (compile-file source-pathname) (setq needs-recompile t)) (load binary-pathname)) From jbielman at common-lisp.net Sat Oct 18 05:06:57 2003 From: jbielman at common-lisp.net (James Bielman) Date: Sat, 18 Oct 2003 01:06:57 -0400 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12867 Modified Files: swank-openmcl.lisp Log Message: (who-calls): Fix bug where we would try to take the TRUENAME of NIL when source information isn't available for a caller. (backtrace-for-emacs): Clean up the backtrace code a bit in preparation for implementing FRAME-LOCALS. (frame-catch-tags): Implement a stub version of this. (frame-locals): Implemented fully for OpenMCL. Date: Sat Oct 18 01:06:57 2003 Author: jbielman Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.9 slime/swank-openmcl.lisp:1.10 --- slime/swank-openmcl.lisp:1.9 Fri Oct 17 17:18:04 2003 +++ slime/swank-openmcl.lisp Sat Oct 18 01:06:57 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.9 2003/10/17 21:18:04 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.10 2003/10/18 05:06:57 jbielman Exp $ ;;; ;;; @@ -221,54 +221,118 @@ (format nil "~A~% [Condition of type ~S]" *swank-debugger-condition* (type-of *swank-debugger-condition*))) -;; This is deep voodoo copied from ccl:lib/backtrace.lisp --- ideally -;; OpenMCL would provide a function for copying backtrace info into a -;; vector or something. -(defun frame-parameters (p tcr lfun pc) - (with-output-to-string (s) - (multiple-value-bind (count vsp parent-vsp) - (ccl::count-values-in-frame p tcr) - (declare (fixnum count)) - (dotimes (i count) - (multiple-value-bind (var type name) - (ccl::nth-value-in-frame p i tcr lfun pc vsp parent-vsp) - (declare (ignore name type)) - (format s " ~S" var)))))) - -;; Also copied almost verbatim from the OpenMCL sources. -(defun compute-backtrace (start end &key (start-frame (ccl::%get-frame-ptr))) +(defun do-backtrace (function &optional + (start-frame-number 0) + (end-frame-number most-positive-fixnum)) + "Call FUNCTION passing information about each stack frame +from frames START-FRAME-NUMBER to END-FRAME-NUMBER." (let ((tcr (ccl::%current-tcr)) - (result) (frame-number 0) - (total 0)) - (do* ((p start-frame (ccl::parent-frame p tcr)) + (top-stack-frame (or *swank-debugger-stack-frame* + (ccl::%get-frame-ptr)))) + (do* ((p top-stack-frame (ccl::parent-frame p tcr)) (q (ccl::last-frame-ptr tcr))) ((or (null p) (eq p q) (ccl::%stack< q p tcr)) (values)) - (declare (fixnum frame-number)) - (progn - (multiple-value-bind (lfun pc) (ccl::cfp-lfun p) - (declare (ignore pc)) - (when lfun - (incf total) - (if (and (>= frame-number start) (< frame-number end)) - (push (list frame-number - (format nil "~D: (~A)" - frame-number - (ccl::%lfun-name-string lfun))) - result)) - (incf frame-number))))) - (values (nreverse result) total))) - -(defslimefun backtrace-for-emacs (start end) - (compute-backtrace start end :start-frame *swank-debugger-stack-frame*)) + (multiple-value-bind (lfun pc) (ccl::cfp-lfun p) + (when lfun + (if (and (>= frame-number start-frame-number) + (< frame-number end-frame-number)) + (funcall function frame-number p tcr lfun pc)) + (incf frame-number)))))) + +(defun backtrace-length () + "Return the total number of frames available in the debugger." + (let ((result 0)) + (do-backtrace #'(lambda (n p tcr lfun pc) + (declare (ignore n p tcr lfun pc)) + (incf result))) + result)) + +(defun frame-arguments (p tcr lfun pc) + "Returns a string representing the arguments of a frame." + (multiple-value-bind (count vsp parent-vsp) + (ccl::count-values-in-frame p tcr) + (let (result) + (dotimes (i count) + (multiple-value-bind (var type name) + (ccl::nth-value-in-frame p i tcr lfun pc vsp parent-vsp) + (when name + (cond ((equal type "required") + (push (to-string var) result)) + ((equal type "optional") + (push (to-string var) result)) + ((equal type "keyword") + (push (format nil "~S ~A" + (intern (symbol-name name) "KEYWORD") + (to-string var)) + result)))))) + (format nil "~{ ~A~}" (nreverse result))))) + +(defslimefun backtrace-for-emacs (&optional + (start-frame-number 0) + (end-frame-number most-positive-fixnum)) + "Return a list containing a stack backtrace of the condition +currently being debugged. The return value of this function is +unspecified unless called in the dynamic contour of a function +defined by DEFINE-DEBUGGER-HOOK. + +START-FRAME-NUMBER and END-FRAME-NUMBER are zero-based indices +constraining the number of frames returned. Frame zero is +defined as the frame which invoked the debugger. + +The backtrace is returned as a list of tuples of the form +\(FRAME-NUMBER FRAME-DESCRIPTION\), where FRAME-NUMBER is the +index of the frame, defined like START-FRAME-NUMBER, and +FRAME-DESCRIPTION is a string containing a textual description +of the call at this stack frame. + +An example return value: + + ((0 \"(HELLO \"world\")) + (1 \"(RUN-EXCITING-LISP-DEMO)\") + (2 \"(SYS::%TOPLEVEL #)\")) + +If the backtrace cannot be calculated, this function returns NIL." + (let (result) + (do-backtrace #'(lambda (frame-number p tcr lfun pc) + (push (list frame-number + (format nil "~D: (~A~A)" frame-number + (ccl::%lfun-name-string lfun) + (frame-arguments p tcr lfun pc))) + result)) + start-frame-number end-frame-number) + (nreverse result))) (defslimefun debugger-info-for-emacs (start end) - (multiple-value-bind (backtrace length) - (backtrace-for-emacs start end) - (list (format-condition-for-emacs) - (format-restarts-for-emacs) - length backtrace))) + (list (format-condition-for-emacs) + (format-restarts-for-emacs) + (backtrace-length) + (backtrace-for-emacs start end))) + +(defslimefun frame-locals (index) + (do-backtrace + #'(lambda (frame-number p tcr lfun pc) + (when (= frame-number index) + (multiple-value-bind (count vsp parent-vsp) + (ccl::count-values-in-frame p tcr) + (let (result) + (dotimes (i count) + (multiple-value-bind (var type name) + (ccl::nth-value-in-frame p i tcr lfun pc vsp parent-vsp) + (declare (ignore type)) + (when name + (push (list + :symbol name + :id 0 + :validity :valid + :value-string (to-string var)) + result)))) + (return-from frame-locals (nreverse result)))))))) + +(defslimefun frame-catch-tags (index) + (declare (ignore index)) + nil) (defun nth-restart (index) (nth index *sldb-restarts*)) @@ -337,7 +401,7 @@ (list nil)) (dolist (caller callers) (let ((source-info (ccl::%source-files caller))) - (when (atom source-info) + (when (and source-info (atom source-info)) (let ((filename (namestring (truename source-info))) ;; This is clearly not the real source path but it will ;; get us into the file at least... @@ -360,3 +424,4 @@ ;;; Macroexpansion (defslimefun-unimplemented swank-macroexpand-all (string)) + From jbielman at common-lisp.net Sat Oct 18 05:07:49 2003 From: jbielman at common-lisp.net (James Bielman) Date: Sat, 18 Oct 2003 01:07:49 -0400 Subject: [slime-cvs] CVS update: slime/.cvsignore Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13053 Modified Files: .cvsignore Log Message: Add OpenMCL and SBCL fasl file extensions. Date: Sat Oct 18 01:07:49 2003 Author: jbielman Index: slime/.cvsignore diff -u slime/.cvsignore:1.1 slime/.cvsignore:1.2 --- slime/.cvsignore:1.1 Thu Oct 16 17:29:34 2003 +++ slime/.cvsignore Sat Oct 18 01:07:49 2003 @@ -1 +1,3 @@ *.x86f +*.fasl +*.dfsl \ No newline at end of file From jbielman at common-lisp.net Sat Oct 18 05:07:54 2003 From: jbielman at common-lisp.net (James Bielman) Date: Sat, 18 Oct 2003 01:07:54 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13079 Modified Files: ChangeLog Log Message: Date: Sat Oct 18 01:07:54 2003 Author: jbielman Index: slime/ChangeLog diff -u slime/ChangeLog:1.40 slime/ChangeLog:1.41 --- slime/ChangeLog:1.40 Fri Oct 17 17:19:47 2003 +++ slime/ChangeLog Sat Oct 18 01:07:54 2003 @@ -1,3 +1,18 @@ +2003-10-17 James Bielman + + * .cvsignore: Add OpenMCL and SBCL fasl file extensions. + + * swank-openmcl.lisp (who-calls): Fix bug where we would try to + take the TRUENAME of NIL when source information isn't available + for a caller. + (backtrace-for-emacs): Clean up the backtrace code a bit in + preparation for implementing FRAME-LOCALS. + (frame-catch-tags): Implement a stub version of this. + (frame-locals): Implemented fully for OpenMCL. + + * swank-loader.lisp (compile-files-if-needed-serially): Be a little + more verbose when compiling files. + 2003-10-17 Helmut Eller * swank.lisp, swank-sbcl.lisp, swank-openmcl.lisp, From heller at common-lisp.net Sat Oct 18 20:06:07 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 18 Oct 2003 16:06:07 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13729 Modified Files: slime.el Log Message: (slime-dispatch-event, slime-activate-state, slime-push-state, slime-pop-state): Add a process-input argument to control processing of pending input. The argument should be true when the function is called in "tail position". Modify callers accordingly. (slime-evaluating-state): Process the available input after printing the "Evaluation aborted." message. (slime-debugging-state): Decrement sldb-level on :debug-return events. The sldb buffer was not reinitialized in programs like (progn (break) (break) t), because the sldb-level had not changed. (slime-compile-region, compile-string): New functions. (slime-compile-defun): Use compile string. (slime-goto-location, slime-goto-source-location): Use full source path when (eq from :stream). Needed for compile-region. (slime-show-note-counts, slime-note-count-string): Suppress style warnings when their count is zero. (sldb-default-action/mouse): Emacs20 compatibility fix. slime-evaluating-state-activation-hook: Hook for testing. (slime-time<, slime-time-add, slime-sync-state-stack): Utilities for testing. (loop-interrupt-quit, loop-interrupt-continue-interrupt-quit, interactive-eval): New tests. Date: Sat Oct 18 16:06:07 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.41 slime/slime.el:1.42 --- slime/slime.el:1.41 Fri Oct 17 15:55:47 2003 +++ slime/slime.el Sat Oct 18 16:06:07 2003 @@ -368,7 +368,7 @@ ;; one). Newlines in messages are displayed as "^J" in emacs20, ;; which is ugly (string-match "^[^\r\n]*" msg) - (message (match-string 0 msg)))) + (message "%s" (match-string 0 msg)))) ;; defun slime-message (if (or (featurep 'xemacs) @@ -597,7 +597,7 @@ (with-current-buffer (process-buffer slime-net-process) (while (slime-net-have-input-p) (save-current-buffer - (slime-dispatch-event (slime-net-read)))))) + (slime-dispatch-event (slime-net-read) nil))))) (defun slime-net-have-input-p () "Return true if a complete message is available." @@ -677,17 +677,19 @@ (defvar slime-state-name "[??]" "The name of the current state, for display in the modeline.") -(defun slime-push-state (state) +(defun slime-push-state (state process-input) "Push into a new state, saving the current state on the stack. -This may be called by a state machine to cause a state change." +This may be called by a state machine to cause a state change. +If PROCESS-INPUT is non-nil the available input is processed." (push state slime-state-stack) - (slime-activate-state)) + (slime-activate-state process-input)) -(defun slime-pop-state () +(defun slime-pop-state (process-input) "Pop back to the previous state from the stack. -This may be called by a state machine to finish its current state." +This may be called by a state machine to finish its current state. +If PROCESS-INPUT is non-nil the available input is processed." (pop slime-state-stack) - (slime-activate-state)) + (slime-activate-state process-input)) (defun slime-current-state () "The current state." @@ -695,13 +697,15 @@ (defun slime-init-dispatcher () "Initialize the stack machine." + (setq sldb-level 0) (setq slime-state-stack (list (slime-idle-state))) (setq slime-pid (slime-eval `(swank:getpid)))) -(defun slime-activate-state () +(defun slime-activate-state (process-input) "Activate the current state. This delivers an (activate) event to the state function, and updates -the state name for the modeline." +the state name for the modeline. +If PROCESS-INPUT is non-nil the available input is processed." (let ((state (slime-current-state))) (setq slime-state-name (case (slime-state-name state) @@ -709,16 +713,18 @@ (slime-evaluating-state "[eval...]") (slime-debugging-state "[debug]"))) (force-mode-line-update) - (slime-dispatch-event '(activate)))) + (slime-dispatch-event '(activate) process-input))) -(defun slime-dispatch-event (event) +(defun slime-dispatch-event (event process-input) "Dispatch an event to the current state. Certain \"out of band\" events are handled specially instead of going -into the state machine." +into the state machine. +If PROCESS-INPUT is non-nil the available input is processed." (unwind-protect (or (slime-handle-oob event) (funcall (slime-state-function (slime-current-state)) event)) - (slime-process-available-input))) + (when process-input + (slime-process-available-input)))) (defun slime-handle-oob (event) "Handle out-of-band events. @@ -780,23 +786,31 @@ (defvar sldb-level 0 "Current debug level, or 0 when not debugging.") +(defvar sldb-level-in-buffer nil + "Buffer local variable in sldb buffer.") + (defvar slime-stack-eval-tags nil "List of stack-tags of continuations waiting on the stack.") (slime-defstate slime-idle-state () "Idle state. The only event allowed is to make a request." ((activate) - (setq sldb-level 0)) + (assert (= sldb-level 0))) ((:emacs-evaluate form-string package-name continuation) (slime-output-evaluate-request form-string package-name) - (slime-push-state (slime-evaluating-state continuation)))) + (slime-push-state (slime-evaluating-state continuation) t))) + +(defvar slime-evaluating-state-activation-hook nil + "Hook called when the evaluating state is actived.") (slime-defstate slime-evaluating-state (continuation) "Evaluting state. We have asked Lisp to evaluate a form, and when the result arrives we will pass it to CONTINUATION." + ((activate) + (run-hooks 'slime-evaluating-state-activation-hook)) ((:ok result) - (slime-pop-state) + (slime-pop-state nil) (destructure-case continuation ((:function f) (funcall f result)) @@ -804,16 +818,18 @@ (when (member tag slime-stack-eval-tags) (throw tag `(:ok ,result)))))) ((:aborted) - (slime-pop-state) (destructure-case continuation ((:function f) - (message "Evaluation aborted.")) + (message "Evaluation aborted.") + (slime-pop-state t)) ((:catch-tag tag) + (slime-pop-state nil) (when (member tag slime-stack-eval-tags) (throw tag `(:aborted)))))) ((:debug level condition restarts stack-depth frames) (slime-push-state - (slime-debugging-state level condition restarts stack-depth frames))) + (slime-debugging-state level condition restarts stack-depth frames) + t)) ((:emacs-interrupt) (slime-send-sigint)) ((:emacs-quit) @@ -826,20 +842,31 @@ Lisp entered the debugger while handling one of our requests. This state interacts with it until it is coaxed into returning." ((activate) - (when (/= level (prog1 sldb-level (setq sldb-level level))) - (sldb-setup condition restarts depth frames))) + (setq sldb-level level) + (let ((sldb-buffer (get-buffer "*sldb*"))) + (when (or (not sldb-buffer) + (with-current-buffer sldb-buffer + (/= sldb-level-in-buffer level))) + (sldb-setup condition restarts depth frames)))) ((:debug-return level) (unwind-protect - (when (= level 1) - (let ((sldb-buffer (get-buffer "*sldb*"))) - (when sldb-buffer - (delete-windows-on sldb-buffer) - (kill-buffer sldb-buffer)))) - (slime-pop-state))) + (progn + (assert (= level sldb-level)) + ;; We must decrement here so we will notice when we are + ;; activated again, especially when we continue from the + ;; debugger and are activated a second time without entering + ;; a lower break level. + (decf sldb-level) + (when (= level 1) + (let ((sldb-buffer (get-buffer "*sldb*"))) + (when sldb-buffer + (delete-windows-on sldb-buffer) + (kill-buffer sldb-buffer))))) + (slime-pop-state t))) ((:emacs-evaluate form-string package-name continuation) ;; recursive evaluation request (slime-output-evaluate-request form-string package-name) - (slime-push-state (slime-evaluating-state continuation)))) + (slime-push-state (slime-evaluating-state continuation) t))) (put 'slime-defstate 'lisp-indent-function 2) @@ -862,7 +889,8 @@ (defun slime-eval-string-async (string package continuation) (when (slime-busy-p) (error "Lisp is already busy evaluating a request.")) - (slime-dispatch-event `(:emacs-evaluate ,string ,package ,continuation))) + (slime-dispatch-event `(:emacs-evaluate ,string ,package ,continuation) + t)) (defconst +slime-sigint+ 2) @@ -996,18 +1024,28 @@ (defun slime-compile-defun () (interactive) + (slime-compile-string (slime-defun-at-point) + (save-excursion + (end-of-defun) + (beginning-of-defun) + (point)))) + +(defun slime-compile-region (start end) + (interactive "r") + (slime-compile-string (buffer-substring-no-properties start end) start)) + +(defun slime-compile-string (string start-offset) (slime-eval-async - `(swank:swank-compile-string ,(slime-defun-at-point) + `(swank:swank-compile-string ,string ,(buffer-name) - ,(save-excursion - (end-of-defun) - (beginning-of-defun) - (point))) + ,start-offset) (slime-buffer-package) (slime-compilation-finished-continuation))) -(defun slime-note-count-string (severity count) - (format "%s %s%s" count severity (if (= count 1) "" "s"))) +(defun slime-note-count-string (severity count &optional suppress-if-zero) + (cond ((and (zerop count) suppress-if-zero) + "") + (t (format "%2d %s%s " count severity (if (= count 1) "" "s"))))) (defun slime-show-note-counts (notes &optional secs) (loop for note in notes @@ -1018,12 +1056,12 @@ count (eq :note severity) into notes finally (message - "Compilation finished: %s %s %s %s%s" + "Compilation finished:%s%s%s%s%s" (slime-note-count-string "error" errors) (slime-note-count-string "warning" warnings) - (slime-note-count-string "style-warning" style-warnings) + (slime-note-count-string "style-warning" style-warnings t) (slime-note-count-string "note" notes) - (if secs (format " [%s secs]" secs) "")))) + (if secs (format "[%s secs]" secs) "")))) (defun slime-compilation-finished (result buffer) (with-current-buffer buffer @@ -1146,13 +1184,12 @@ (defun slime-most-severe (sev1 sev2) "Return the most servere of two conditions. Severity is ordered as :NOTE < :STYLE-WARNING < :WARNING < :ERROR." - (if (or (eq sev1 :error) ; Well, not exactly Smullyan.. - (and (eq sev1 :warning) - (not (eq sev2 :error))) - (and (eq sev1 :style-warning) - (not (member sev2 '(:warning :error))))) - sev1 - sev2)) + ; Well, not exactly Smullyan.. + (let ((order '(:note :style-warning :warning :error))) + (if (>= (position sev1 order) + (position sev2 order)) + sev1 + sev2))) (defun slime-visit-source-path (source-path) "Visit a full source path including the top-level form." @@ -1170,11 +1207,10 @@ (let ((origin (point))) (condition-case nil (progn - (loop for form-number in source-path - for more downfrom (1- (length source-path)) + (loop for (count . more) on source-path do (progn - (slime-forward-sexp form-number) - (unless (zerop more) (down-list 1)))) + (slime-forward-sexp count) + (when more (down-list 1)))) ;; Align at beginning (slime-forward-sexp) (beginning-of-sexp)) @@ -1219,7 +1255,7 @@ ((stringp (plist-get note :buffername)) (assert (string= (buffer-name) (plist-get note :buffername))) (goto-char (plist-get note :buffer-offset)) - (slime-forward-positioned-source-path (plist-get note ':source-path))) + (slime-forward-source-path (plist-get note ':source-path))) (t (error "Unsupported location type %s" note)))) @@ -1933,9 +1969,14 @@ (error "No context for finding locations.")) (funcall slime-next-location-function)) - ;;; +(defvar slime-select-mode-map) +(defvar slime-previous-selected-line) +(defvar slime-select-finish) +(defvar slime-select-follow) +(defvar slime-select-saved-window-configuration) + (defun slime-list-callers (symbol-name) (interactive (list (slime-read-symbol-name "List callers: "))) (slime-eval-select-function-list `(swank:list-callers ,symbol-name))) @@ -1972,14 +2013,27 @@ (error (message "%s" (error-message-string e)) (ding)))) +(defvar slime-select-split-window-vectically nil) + (defun slime-get-select-window (labels) - (split-window (selected-window) - (- (frame-width) - (min (1+ (max - (loop for l in labels maximize (length l)) - window-min-width)) - 25)) - t)) + (cond (slime-select-split-window-vectically + (split-window (selected-window) + (- (frame-width) + (min (1+ (max + (loop for l in labels maximize (length l)) + window-min-width)) + 25)) + t)) + (t + (cond ((one-window-p) + (split-window (selected-window))) + (t (next-window)))))) + +(defun slime-select-pop-to-window (buffer labels) + (let ((window (slime-get-select-window labels))) + (set-window-buffer window (current-buffer)) + (select-window window) + (shrink-window-if-larger-than-buffer window))) (defun slime-select (labels follow finish) "Select an item form the list LABELS. @@ -2000,13 +2054,8 @@ (setq buffer-read-only t) (setq slime-select-saved-window-configuration (current-window-configuration)) - (let ((window (slime-get-select-window labels))) - (set-window-buffer window (current-buffer)) - (select-window window) - (slime-select-post-command-hook))) - -(defvar slime-select-mode-map) -(defvar slime-previous-selected-line) + (slime-select-pop-to-window (current-buffer) labels) + (slime-select-post-command-hook)) (defun slime-selected-line () (count-lines (point-min) (save-excursion (beginning-of-line) (point)))) @@ -2071,11 +2120,11 @@ (defun slime-interrupt () (interactive) - (slime-dispatch-event '(:emacs-interrupt))) + (slime-dispatch-event '(:emacs-interrupt) t)) (defun slime-quit () (interactive) - (slime-dispatch-event '(:emacs-quit))) + (slime-dispatch-event '(:emacs-quit) t)) (defun slime-set-package (package) (interactive (list (slime-read-package-name "Package: " @@ -2109,14 +2158,6 @@ (defvar sldb-hook nil "Hook run on entry to the debugger.") -(defun slime-debugger-hook () - (slime-enter-sldb)) - -(defun slime-enter-sldb () - (slime-move-to-state (slime-state sldb-state (slime-current-state))) - (incf sldb-level) - (slime-net-send `(swank:sldb-loop))) - (defun sldb-setup (condition restarts stack-depth frames) (with-current-buffer (get-buffer-create "*sldb*") (setq buffer-read-only nil) @@ -2199,7 +2240,7 @@ (defun sldb-default-action/mouse (event) (interactive "e") - (destructuring-bind (mouse-1 (w pos (x . y) time)) event + (destructuring-bind (mouse-1 (w pos &rest _)) event (save-excursion (goto-char pos) (let ((fn (get-text-property (point) 'sldb-default-action))) @@ -2256,7 +2297,7 @@ #'switch-to-buffer) (get-buffer buffer)) (goto-char offset) - (slime-forward-positioned-source-path + (slime-forward-source-path (plist-get source-location :path)))) (t (error "Cannot locate source from stream: %s" @@ -2326,7 +2367,7 @@ (apply #'sldb-maybe-recenter-region (sldb-frame-region))) (defun sldb-maybe-recenter-region (start end) - (sit-for 0 1) + (sit-for 0 nil) (cond ((and (< (window-start) start) (< end (window-end)))) (t @@ -2426,7 +2467,7 @@ (defun sldb-quit () (interactive) - (slime-eval-async '(swank:throw-to-toplevel) nil (lambda ()))) + (slime-eval-async '(swank:throw-to-toplevel) nil (lambda (_)))) (defun sldb-continue () (interactive) @@ -2809,18 +2850,18 @@ (def-slime-test compile-defun (program subform) "Compile PROGRAM containing errors. -Confirm that SUBFORM is correctly located." + Confirm that SUBFORM is correctly located." '(("(defun :foo () (:bar))" (:bar)) ("(defun :foo () - #\\space - ;;Sdf - (:bar))" + #\\space + ;;Sdf + (:bar))" (:bar)) ("(defun :foo () - #+(or)skipped - #| #||# - #||# |# - (:bar))" + #+(or)skipped + #| #||# + #||# |# + (:bar))" (:bar)) ("(defun :foo () (list `(1 ,(random 10) 2 ,@(random 10) 3 ,(:bar))))" (:bar)) @@ -2833,8 +2874,8 @@ (slime-previous-note) (slime-check error-location-correct (equal (read (current-buffer)) - subform)))) - + subform)))) + (def-slime-test async-eval-debugging (depth) "Test recursive debugging of asynchronous evaluation requests." '((1) (2) (3)) @@ -2871,15 +2912,130 @@ debug-hook-max-depth depth) (= debug-hook-max-depth depth)) ;; FIXME: synchronize properly somehow. We are expecting Lisp - ;; to perform a restart and unwind our stack. - (sit-for 2) - ;; and the restart should have put us back at the top level + ;; to perform a restart and unwind our stack. and the restart + ;; should have put us back at the top level. + (slime-sync-state-stack '(slime-idle-state) 5) (slime-check "Automaton is back in idle state." (slime-test-state-stack '(slime-idle-state))))))) (defun slime-test-state-stack (states) "True if STATES describes the current stack of states." (equal states (mapcar #'slime-state-name slime-state-stack))) + +(defun slime-time< (time1 time2) + "Compare two encoded time values." + (multiple-value-bind (high1 low1 micros1) time1 + (multiple-value-bind (high2 low2 micros2) time2 + (or (< high1 high2) + (and (= high1 high2) + (or (< low1 low2) + (and (= low1 low2) + (if (and micros1 micros2) + (< micros1 micros2) + micros2)))))))) + +(defun* slime-time-add (time &key (second 0) (minute 0) (hour 0) + (day 0) (month 0) (year 0)) + "Add the specified time to the encoded time value TIME." + (multiple-value-bind (old-second old-minute old-hour + old-day old-month old-year + old-dow old-dst old-zone) + (decode-time time) + (encode-time (+ old-second second) + (+ old-minute minute) + (+ old-hour hour) + (+ old-day day) + (+ old-month month) + (+ old-year year) + old-zone))) + +(defun slime-sync-state-stack (state-stack timeout) + "Wait until the machine's stack is STATE-STACK or the timeout \ +expires.\nThe timeout is given in seconds." + (let ((end (slime-time-add (current-time) :second timeout))) + (loop until (or (slime-test-state-stack state-stack) + (slime-time< end (current-time))) + do (accept-process-output nil 0 100000)))) + +(def-slime-test loop-interrupt-quit () + "Test interrupting a loop." + '(()) + (slime-check "Automaton initially in idle state." + (slime-test-state-stack '(slime-idle-state))) + (slime-eval-async '(loop) "CL-USER" (lambda (_) )) + (let ((sldb-hook + (lambda () + (slime-check "First interrupt." + (and (slime-test-state-stack '(slime-debugging-state + slime-evaluating-state + slime-idle-state)) + (get-buffer "*sldb*"))) + (sldb-quit)))) + (accept-process-output nil 1) + (slime-check "In eval state." + (slime-test-state-stack '(slime-evaluating-state slime-idle-state))) + (slime-interrupt) + (slime-sync-state-stack '(slime-idle-state) 5) + (slime-check "Automaton is back in idle state." + (slime-test-state-stack '(slime-idle-state))))) + +(def-slime-test loop-interrupt-continue-interrupt-quit () + "Test interrupting a previously interrupted but continued loop." + '(()) + (slime-check "Automaton initially in idle state." + (slime-test-state-stack '(slime-idle-state))) + (slime-eval-async '(loop) "CL-USER" (lambda (_) )) + (let ((sldb-hook + (lambda () + (slime-check "First interrupt." + (and (slime-test-state-stack '(slime-debugging-state + slime-evaluating-state + slime-idle-state)) + (get-buffer "*sldb*"))) + (let ((slime-evaluating-state-activation-hook + (lambda () + (when (slime-test-state-stack '(slime-evaluating-state + slime-idle-state)) + (setq slime-evaluating-state-activation-hook nil) + (slime-check "No sldb buffer." + (not (get-buffer "*sldb*"))) + (let ((sldb-hook + (lambda () + (slime-check "Second interrupt." + (and (slime-test-state-stack + '(slime-debugging-state + slime-evaluating-state + slime-idle-state)) + (get-buffer "*sldb*"))) + (sldb-quit)))) + (accept-process-output nil 1) + (slime-check "In eval state." + (slime-test-state-stack + '(slime-evaluating-state slime-idle-state))) + (slime-interrupt) + (slime-sync-state-stack '(slime-idle-state) 5)))))) + (sldb-continue) + (slime-sync-state-stack '(slime-idle-state) 5))))) + (accept-process-output nil 1) + (slime-check "In eval state." + (slime-test-state-stack '(slime-evaluating-state slime-idle-state))) + (slime-interrupt) + (slime-sync-state-stack '(slime-idle-state) 5) + (slime-check "Automaton is back in idle state." + (slime-test-state-stack '(slime-idle-state))))) + +(def-slime-test interactive-eval () + "Test interactive eval and continuing from the debugger." + '(()) + (let ((sldb-hook (lambda () (sldb-continue)))) + (slime-interactive-eval + "(progn (cerror \"foo\" \"restart\") (cerror \"bar\" \"restart\") t)") + (slime-sync-state-stack '(slime-idle-state) 5) + (slime-check "Automaton is back in idle state." + (slime-test-state-stack '(slime-idle-state))) + (let ((message (current-message))) + (slime-check "Minibuffer contains: \"=> t\"" + (equal "=> t" message))))) ;;; Portability library From heller at common-lisp.net Sat Oct 18 20:14:35 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 18 Oct 2003 16:14:35 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17907 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Oct 18 16:14:35 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.41 slime/ChangeLog:1.42 --- slime/ChangeLog:1.41 Sat Oct 18 01:07:54 2003 +++ slime/ChangeLog Sat Oct 18 16:14:35 2003 @@ -1,3 +1,10 @@ +2003-10-18 Helmut Eller + + * slime.el: Fix some bugs in the state machine and be a bit more + careful when processing pending input. + (slime-compile-region): New command. + Some more tests. + 2003-10-17 James Bielman * .cvsignore: Add OpenMCL and SBCL fasl file extensions. From lgorrie at common-lisp.net Sun Oct 19 10:05:57 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 19 Oct 2003 06:05:57 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18036 Modified Files: ChangeLog Log Message: s/Christopher/Christophe/g -- oops! Date: Sun Oct 19 06:05:56 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.42 slime/ChangeLog:1.43 --- slime/ChangeLog:1.42 Sat Oct 18 16:14:35 2003 +++ slime/ChangeLog Sun Oct 19 06:05:56 2003 @@ -33,14 +33,14 @@ 21.5. (Thanks Raymond Toy.) * swank-sbcl.lisp: Report style-warnings separately from notes - (patch from Christopher Rhodes). Use REQUIRE to load sb-introspect + (patch from Christophe Rhodes). Use REQUIRE to load sb-introspect instead of loading the source file (requires the sb-introspect library to be installed, which doesn't yet happen in the sourceforge-lagged SBCL anoncvs, but does in the real one). * slime.el (slime-style-warning-face): Added style-warnings, which are between a warning and a note in severity. (Patch from - Christopher Rhodes). + Christophe Rhodes). * test.sh: When the test fails to complete, print "crashed" instead of reporting nonsense. From lgorrie at common-lisp.net Sun Oct 19 10:45:06 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 19 Oct 2003 06:45:06 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14045 Modified Files: slime.el Log Message: (slime): Connection setup is now asynchronous, with retrying on a timer. This makes it possible to bring the server up by hand while debugging. `M-x slime' while already connected will cause the old connection to be dropped and a new one established. (slime-disconnect): New command to disconnect from Swank, or cancel asynchronous connection attempts when not yet connected. Date: Sun Oct 19 06:45:06 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.42 slime/slime.el:1.43 --- slime/slime.el:1.42 Sat Oct 18 16:06:07 2003 +++ slime/slime.el Sun Oct 19 06:45:06 2003 @@ -478,17 +478,31 @@ ;;; CMUCL Setup: compiling and connecting to Swank -;; SLIME -- command -;; +(defvar slime-connect-retry-timer nil + "Timer object for connection retries.") + (defun slime () "Start an inferior^_superior Lisp and connect to its Swank server." (interactive) - (call-interactively 'inferior-lisp) - (slime-start-swank-server) + (when (slime-connected-p) + (slime-disconnect)) + (slime-maybe-start-lisp) (slime-connect "localhost" slime-swank-port)) -;; SLIME-CONNECT -- command -;; +(defun slime-maybe-start-lisp () + "Start an inferior lisp unless one is already running." + (unless (get-buffer "*inferior-lisp*") + (call-interactively 'inferior-lisp) + (slime-start-swank-server))) + +(defun slime-start-swank-server () + "Start a Swank server on the inferior lisp." + (comint-proc-query (inferior-lisp-proc) + (format "(load %S)\n" + (concat slime-path slime-backend))) + (comint-proc-query (inferior-lisp-proc) + (format "(swank:start-server %S)\n" slime-swank-port))) + (defun slime-connect (host port &optional retries) "Connect to a running Swank server." (interactive (list (read-string "Host: " "localhost") @@ -496,28 +510,49 @@ (read-string "Port: " (number-to-string slime-swank-port)))) (or (ignore-errors (string-to-number port)) port)))) - (let ((retries slime-swank-connection-retries)) - (while (not (slime-connected-p)) - (message "Connecting to Swank at %s:%S%s..." - host port (if retries - (format " (%S attempts remaining)" retries) - "")) - (if (slime-net-connect host port) - (progn (slime-init-dispatcher) - (slime-fetch-features-list) + (lexical-let ((host host) + (port port) + (retries (or retries slime-swank-connection-retries)) + (attempt 0)) + (labels + ;; A small one-state machine to attempt a connection with + ;; timer-based retries. + ((attempt-connection + () + (setq slime-state-name (format "[connect:%S]" (incf attempt))) + (force-mode-line-update) + (setq slime-connect-retry-timer nil) ; remove old timer + (cond ((slime-net-connect host port) + (slime-init-connection) (message "Connected to Swank on %s:%S. %s" host port (slime-random-words-of-encouragement))) - (when (and retries (zerop (decf retries))) - (error "Unable to contact Swank server.")) - (sit-for 0.25))))) + ((and retries (zerop retries)) + (message "Failed to connect to Swank.")) + (t + (when retries (decf retries)) + (setq slime-connect-retry-timer + (run-with-timer 1 nil #'attempt-connection)))))) + (message "\ +Connecting to Swank at %s:%S. (Abort with `M-x slime-disconnect'.)" + host port) + (attempt-connection)))) + +(defun slime-disconnect () + "Disconnect from the Swank server." + (interactive) + (cond ((slime-connected-p) + (delete-process slime-net-process) + (message "Disconnected.")) + (slime-connect-retry-timer + (cancel-timer slime-connect-retry-timer) + (message "Cancelled connection attempt.")) + (t + (message "Not connected.")))) -(defun slime-start-swank-server () - "Start a Swank server on the inferior lisp." - (comint-proc-query (inferior-lisp-proc) - (format "(load %S)\n" - (concat slime-path slime-backend))) - (comint-proc-query (inferior-lisp-proc) - (format "(swank:start-server %S)\n" slime-swank-port))) +(defun slime-init-connection () + (slime-init-dispatcher) + (setq slime-pid (slime-eval '(swank:getpid))) + (slime-fetch-features-list)) (defun slime-fetch-features-list () "Fetch and remember the *FEATURES* of the inferior lisp." @@ -698,8 +733,7 @@ (defun slime-init-dispatcher () "Initialize the stack machine." (setq sldb-level 0) - (setq slime-state-stack (list (slime-idle-state))) - (setq slime-pid (slime-eval `(swank:getpid)))) + (setq slime-state-stack (list (slime-idle-state)))) (defun slime-activate-state (process-input) "Activate the current state. @@ -933,7 +967,7 @@ (defun slime-sync () "Block until any asynchronous command has completed." (while (slime-busy-p) - (accept-process-output))) + (accept-process-output slime-net-process))) (defun slime-busy-p () "Return true if Lisp is busy processing a request." @@ -1898,7 +1932,7 @@ 'font-lock-function-name-face 'font-lock-comment-face)) (format "%s\n" referrer))))) - + ;;;;; XREF results buffer and window management @@ -1969,7 +2003,8 @@ (error "No context for finding locations.")) (funcall slime-next-location-function)) -;;; + +;;; List callers/callees (defvar slime-select-mode-map) (defvar slime-previous-selected-line) @@ -2692,6 +2727,8 @@ (slime-swank-port 4006) ; different port than interactive use (slime-test-debug-on-error nil)) (slime) + ;; Block until we are up and running. + (slime-sync-state-stack '(slime-idle-state) 120) (switch-to-buffer "*scratch*") (let ((failed-tests (slime-run-tests))) (with-current-buffer slime-test-buffer-name From lgorrie at common-lisp.net Sun Oct 19 10:45:25 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 19 Oct 2003 06:45:25 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14254 Modified Files: ChangeLog Log Message: Date: Sun Oct 19 06:45:25 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.43 slime/ChangeLog:1.44 --- slime/ChangeLog:1.43 Sun Oct 19 06:05:56 2003 +++ slime/ChangeLog Sun Oct 19 06:45:24 2003 @@ -1,3 +1,12 @@ +2003-10-19 Luke Gorrie + + * slime.el (slime): Connection setup is now asynchronous, with + retrying on a timer. This makes it possible to bring the server up + by hand while debugging. `M-x slime' while already connected will + cause the old connection to be dropped and a new one established. + (slime-disconnect): New command to disconnect from Swank, or + cancel asynchronous connection attempts when not yet connected. + 2003-10-18 Helmut Eller * slime.el: Fix some bugs in the state machine and be a bit more From lgorrie at common-lisp.net Sun Oct 19 12:25:29 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 19 Oct 2003 08:25:29 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv27767 Modified Files: slime.el Log Message: (slime-state/event-panic): Illegal events in the communication state machine now trigger a general panic that disconnects from Lisp and displays a message describing what has happened. This is a bug situation. Date: Sun Oct 19 08:25:29 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.43 slime/slime.el:1.44 --- slime/slime.el:1.43 Sun Oct 19 06:45:06 2003 +++ slime/slime.el Sun Oct 19 08:25:29 2003 @@ -616,7 +616,9 @@ (process-send-string slime-net-process (string-make-unibyte string)))) (defun slime-net-sentinel (process message) - (message "wire sentinel: %s" message) + (message "Lisp connection closed: %s" message) + (setq slime-state-name "[not connected]") + (force-mode-line-update) (ignore-errors (kill-buffer (process-buffer slime-net-process)))) (defun slime-net-filter (process string) @@ -782,6 +784,43 @@ "Return STATE's event-handler function." (third state)) +(defun slime-state/event-panic (event) + "Signal the error that we received EVENT in a state that can't handle it. +When this happens it is due to a bug in SLIME. + +The connection to Lisp is dropped, the user is presented with some +debugging information, and an error is signaled." + (with-output-to-temp-buffer "*SLIME bug*" + (princ (format "\ +You have encountered a bug in SLIME. + +The communication state machine received an event that was illegal for +its current state, which means that the communication between Emacs +and Lisp has lost synchronization. The connection to Lisp has +therefore been closed. + +You can open a fresh connection with `M-x slime'. + +Please report this problem to your friendly neighbourhood SLIME +hacker, or the mailing list at slime-devel at common-lisp.net. Please +include in your report: + + A description of what you were doing when the problem occured, + the version of SLIME, Emacs, and Lisp that you are using, + the Lisp backtrace, if one was printed, + and the information printed below: + +The event was: +%s + +The state stack was: +%s" + (pp-to-string event) + (pp-to-string (mapcar 'slime-state-name + slime-state-stack))))) + (slime-disconnect) + (error "The SLIME protocol reached an inconsistent state.")) + ;;;;; Upper layer macros for defining states @@ -799,9 +838,9 @@ ,@(if (member* '(activate) clauses :key #'car :test #'equal) '() '( ((activate) nil)) ) - (t (error "Can't handle event %S in state %S" - ,event-var - (slime-state-name (slime-current-state)))))))))) + (t + ;; Illegal event for current state. This is a BUG! + (slime-state/event-panic ,event-var)))))))) (defmacro slime-defstate (name variables doc &rest events) "Define a state called NAME and comprised of VARIABLES. From lgorrie at common-lisp.net Sun Oct 19 12:25:51 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 19 Oct 2003 08:25:51 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv27831 Modified Files: ChangeLog Log Message: Date: Sun Oct 19 08:25:51 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.44 slime/ChangeLog:1.45 --- slime/ChangeLog:1.44 Sun Oct 19 06:45:24 2003 +++ slime/ChangeLog Sun Oct 19 08:25:51 2003 @@ -6,6 +6,10 @@ cause the old connection to be dropped and a new one established. (slime-disconnect): New command to disconnect from Swank, or cancel asynchronous connection attempts when not yet connected. + (slime-state/event-panic): Illegal events in the communication + state machine now trigger a general panic that disconnects from + Lisp, and displays a message describing what has happened. This is + a bug situation. 2003-10-18 Helmut Eller From lgorrie at common-lisp.net Sun Oct 19 16:17:22 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 19 Oct 2003 12:17:22 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18768 Modified Files: slime.el Log Message: (slime-connect): Print a message during connection attempts unless the minibuffer is active (it's annoying to get messages while trying to enter commands). Date: Sun Oct 19 12:17:21 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.44 slime/slime.el:1.45 --- slime/slime.el:1.44 Sun Oct 19 08:25:29 2003 +++ slime/slime.el Sun Oct 19 12:17:21 2003 @@ -519,6 +519,10 @@ ;; timer-based retries. ((attempt-connection () + (unless (active-minibuffer-window) + (message "\ +Connecting to Swank at %s:%S. (Abort with `M-x slime-disconnect'.)" + host port)) (setq slime-state-name (format "[connect:%S]" (incf attempt))) (force-mode-line-update) (setq slime-connect-retry-timer nil) ; remove old timer @@ -532,9 +536,6 @@ (when retries (decf retries)) (setq slime-connect-retry-timer (run-with-timer 1 nil #'attempt-connection)))))) - (message "\ -Connecting to Swank at %s:%S. (Abort with `M-x slime-disconnect'.)" - host port) (attempt-connection)))) (defun slime-disconnect () From lgorrie at common-lisp.net Sun Oct 19 16:17:29 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 19 Oct 2003 12:17:29 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18799 Modified Files: ChangeLog Log Message: Date: Sun Oct 19 12:17:28 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.45 slime/ChangeLog:1.46 --- slime/ChangeLog:1.45 Sun Oct 19 08:25:51 2003 +++ slime/ChangeLog Sun Oct 19 12:17:28 2003 @@ -10,6 +10,9 @@ state machine now trigger a general panic that disconnects from Lisp, and displays a message describing what has happened. This is a bug situation. + (slime-connect): Print a message during connection attempts unless + the minibuffer is active (it's annoying to get messages while + trying to enter commands). 2003-10-18 Helmut Eller From heller at common-lisp.net Sun Oct 19 21:36:21 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 19 Oct 2003 17:36:21 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19059 Modified Files: slime.el Log Message: Support for input redirection. (slime-activate-state, slime-evaluating-state, slime-read-input-state): Add new read-input-state. (slime-show-output-buffer): New function. slime-hide-style-warning-count-if-zero: Make suppression of style-warnings customizable. (sldb-show-frame-details): Fix indentation of catch-tags. Date: Sun Oct 19 17:36:21 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.45 slime/slime.el:1.46 --- slime/slime.el:1.45 Sun Oct 19 12:17:21 2003 +++ slime/slime.el Sun Oct 19 17:36:21 2003 @@ -745,10 +745,11 @@ If PROCESS-INPUT is non-nil the available input is processed." (let ((state (slime-current-state))) (setq slime-state-name - (case (slime-state-name state) + (ecase (slime-state-name state) (slime-idle-state "") (slime-evaluating-state "[eval...]") - (slime-debugging-state "[debug]"))) + (slime-debugging-state "[debug]") + (slime-read-input-state "[read]"))) (force-mode-line-update) (slime-dispatch-event '(activate) process-input))) @@ -852,7 +853,7 @@ ,doc (slime-make-state ',name ,(slime-make-state-function variables events)))) - +(put 'slime-defstate 'lisp-indent-function 2) ;;;;; The SLIME state machine definition @@ -909,7 +910,9 @@ ((:emacs-quit) ;; To discard the state would break our synchronization. ;; Instead, just cancel the continuation. - (setq continuation (lambda (value) t)))) + (setq continuation (lambda (value) t))) + ((:read-input requested tag) + (slime-push-state (slime-read-input-state requested tag) t))) (slime-defstate slime-debugging-state (level condition restarts depth frames) "Debugging state. @@ -942,7 +945,17 @@ (slime-output-evaluate-request form-string package-name) (slime-push-state (slime-evaluating-state continuation) t))) -(put 'slime-defstate 'lisp-indent-function 2) +(slime-defstate slime-read-input-state (request tag) + "Reading state. +Lisp waits for input from Emacs." + ((activate) + (let (input) + (while (or (not input) + (zerop (length input))) + (slime-show-output-buffer) + (setq input (ignore-errors (read-string "<= ")))) + (slime-net-send `(swank:take-input ,tag ,(concat input "\n"))) + (slime-pop-state t)))) ;;;;; Utilities @@ -1016,7 +1029,7 @@ (defun slime-ping () "Check that communication works." (interactive) - (message (slime-eval "PONG"))) + (message "%s" (slime-eval "PONG"))) ;;; Stream output @@ -1065,6 +1078,12 @@ (slime-save-window-configuration) (pop-to-buffer (slime-output-buffer) nil t)) +(defun slime-show-output-buffer () + (slime-show-last-output) + (with-current-buffer (slime-output-buffer) + (goto-char (point-max)) + (display-buffer (slime-output-buffer) t))) + ;;; Compilation and the creation of compiler-note annotations @@ -1116,6 +1135,8 @@ (slime-buffer-package) (slime-compilation-finished-continuation))) +(defvar slime-hide-style-warning-count-if-zero t) + (defun slime-note-count-string (severity count &optional suppress-if-zero) (cond ((and (zerop count) suppress-if-zero) "") @@ -1133,7 +1154,8 @@ "Compilation finished:%s%s%s%s%s" (slime-note-count-string "error" errors) (slime-note-count-string "warning" warnings) - (slime-note-count-string "style-warning" style-warnings t) + (slime-note-count-string "style-warning" style-warnings + slime-hide-style-warning-count-if-zero) (slime-note-count-string "note" notes) (if secs (format "[%s secs]" secs) "")))) @@ -1490,7 +1512,7 @@ (slime-buffer-package) (lexical-let ((symbol-name symbol-name)) (lambda (arglist) - (message (slime-format-arglist symbol-name arglist)))))) + (message "%s" (slime-format-arglist symbol-name arglist)))))) (defun slime-get-arglist (symbol-name) "Return the argument list for SYMBOL-NAME." @@ -2421,22 +2443,24 @@ (let* ((props (text-properties-at (point))) (frame (plist-get props 'frame)) (frame-number (car frame)) - (standard-output (current-buffer))) + (standard-output (current-buffer)) + (indent1 " ") + (indent2 " ")) (goto-char start) (delete-region start end) (sldb-propertize-region (plist-put props 'details-visible-p t) (insert (second frame) "\n" - " Locals:\n") - (sldb-princ-locals frame-number " ") + indent1 "Locals:\n") + (sldb-princ-locals frame-number indent2) (let ((catchers (sldb-catch-tags frame-number))) (cond ((null catchers) - (princ " [No catch-tags]\n")) + (insert indent1 "[No catch-tags]\n")) (t - (princ " Catch-tags:\n") + (insert indent1 "Catch-tags:\n") (loop for (tag . location) in catchers do (slime-insert-propertized '(catch-tag ,tag) - (format " %S\n" tag)))))) + indent2 (format "%S\n" tag)))))) (terpri) (point))))) (apply #'sldb-maybe-recenter-region (sldb-frame-region))) From heller at common-lisp.net Sun Oct 19 21:38:45 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 19 Oct 2003 17:38:45 -0400 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19581 Modified Files: swank-cmucl.lisp Log Message: First shoot at input redirection. slime-input-stream: New structure. *read-input-catch-tag*: New variable. slime-input-stream/n-bin, take-input: New functions. serve-request: Bind input streams. Date: Sun Oct 19 17:38:45 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.8 slime/swank-cmucl.lisp:1.9 --- slime/swank-cmucl.lisp:1.8 Fri Oct 17 17:18:04 2003 +++ slime/swank-cmucl.lisp Sun Oct 19 17:38:45 2003 @@ -43,6 +43,31 @@ (return count)))) (t (lisp::string-out-misc stream operation arg1 arg2)))) +(defstruct (slime-input-stream + (:include lisp::lisp-stream + (lisp::n-bin #'slime-input-stream/n-bin) + (lisp::in #'read-char) ; make read-line happy. + (lisp::bin #'read-byte) + (lisp::in-buffer + (make-array lisp::in-buffer-length + :element-type '(unsigned-byte 8))) + (lisp::in-index lisp::in-buffer-length)))) + +(defvar *read-input-catch-tag* 0) + +(defun slime-input-stream/n-bin (stream buffer start requested eof-errorp) + (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*))) + (send-to-emacs `(:read-input ,requested ,*read-input-catch-tag*)) + (let ((input (catch *read-input-catch-tag* + (read-from-emacs)))) + (loop for c across input + for i from start + do (setf (aref buffer i) (char-code c))) + (length input)))) + +(defslimefun take-input (tag input) + (throw tag input)) + (defun create-swank-server (port &key reuse-address (address "localhost")) "Create a SWANK TCP server." (let* ((hostent (ext:lookup-host-entry address)) @@ -60,16 +85,18 @@ (defun setup-request-handler (socket) "Setup request handling for SOCKET." - (let ((stream (sys:make-fd-stream socket + (let* ((stream (sys:make-fd-stream socket :input t :output t :element-type 'unsigned-byte)) - (output (make-slime-output-stream))) + (input (make-slime-input-stream)) + (output (make-slime-output-stream)) + (io (make-two-way-stream input output))) (system:add-fd-handler socket :input (lambda (fd) (declare (ignore fd)) - (serve-request stream output))))) + (serve-request stream output input io))))) -(defun serve-request (*emacs-io* *slime-output*) +(defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*) "Read and process a request from a SWANK client. The request is read from the socket as a sexp and then evaluated." (let ((completed nil)) From heller at common-lisp.net Sun Oct 19 21:39:40 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 19 Oct 2003 17:39:40 -0400 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20906 Modified Files: swank.lisp Log Message: First shoot at input redirection. *slime-input*, *slime-io*: New variables. Date: Sun Oct 19 17:39:40 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.38 slime/swank.lisp:1.39 --- slime/swank.lisp:1.38 Fri Oct 17 17:18:04 2003 +++ slime/swank.lisp Sun Oct 19 17:39:40 2003 @@ -44,6 +44,12 @@ (defvar *slime-output* nil "Bound to a slime-output-stream during request processing.") +(defvar *slime-input* nil + "Bound to a slime-input-stream during request processing.") + +(defvar *slime-io* nil + "Bound to a two-way-stream built from *slime-input* and *slime-output*.") + (defparameter *redirect-output* t) (defun read-from-emacs () @@ -53,8 +59,9 @@ (let ((*standard-output* *slime-output*) (*error-output* *slime-output*) (*trace-output* *slime-output*) - (*debug-io* *slime-output*) - (*query-io* *slime-output*)) + (*debug-io* *slime-io*) + (*query-io* *slime-io*) + (*standard-input* *slime-input*)) (apply #'funcall form)) (apply #'funcall form)))) From heller at common-lisp.net Sun Oct 19 21:40:29 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 19 Oct 2003 17:40:29 -0400 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20973 Modified Files: swank-sbcl.lisp swank-openmcl.lisp Log Message: Bind *slime-input* and *slime-io* to dummy values. Date: Sun Oct 19 17:40:29 2003 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.9 slime/swank-sbcl.lisp:1.10 --- slime/swank-sbcl.lisp:1.9 Fri Oct 17 17:18:04 2003 +++ slime/swank-sbcl.lisp Sun Oct 19 17:40:28 2003 @@ -79,7 +79,9 @@ "Read and process a request from a SWANK client. The request is read from the socket as a sexp and then evaluated." (let* ((completed nil) - (*slime-output* (make-instance 'slime-output-stream))) + (*slime-output* (make-instance 'slime-output-stream)) + (*slime-input* *standard-input*) + (*slime-io* (make-two-way-stream *slime-input* *slime-output*))) (let ((condition (catch 'serve-request-catcher (read-from-emacs) (setq completed t)))) Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.10 slime/swank-openmcl.lisp:1.11 --- slime/swank-openmcl.lisp:1.10 Sat Oct 18 01:06:57 2003 +++ slime/swank-openmcl.lisp Sun Oct 19 17:40:29 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.10 2003/10/18 05:06:57 jbielman Exp $ +;;; $Id: swank-openmcl.lisp,v 1.11 2003/10/19 21:40:29 heller Exp $ ;;; ;;; @@ -82,7 +82,10 @@ (catch 'slime-toplevel (with-simple-restart (abort "Return to Slime event loop.") (let ((completed nil)) - (let ((*slime-output* (make-instance 'slime-output-stream))) + (let* ((*slime-output* (make-instance 'slime-output-stream)) + (*slime-input* *standard-input*) + (*slime-io* (make-two-way-stream *slime-input* + *slime-output*))) (let ((condition (catch 'serve-request-catcher (read-from-emacs) (setq completed t)))) From heller at common-lisp.net Sun Oct 19 21:43:42 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 19 Oct 2003 17:43:42 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22243 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Oct 19 17:43:41 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.46 slime/ChangeLog:1.47 --- slime/ChangeLog:1.46 Sun Oct 19 12:17:28 2003 +++ slime/ChangeLog Sun Oct 19 17:43:41 2003 @@ -1,3 +1,11 @@ +2003-10-19 Helmut Eller + + * slime.el, swank-cmucl.lisp, swank.lisp: First shoot at input + redirection. + + * swank-sbcl.lisp, swank-openmcl.lisp: Bind *slime-input* and + *slime-io* to dummy values. + 2003-10-19 Luke Gorrie * slime.el (slime): Connection setup is now asynchronous, with From dbarlow at common-lisp.net Mon Oct 20 13:56:22 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Mon, 20 Oct 2003 09:56:22 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5890 Modified Files: ChangeLog Log Message: Date: Mon Oct 20 09:56:22 2003 Author: dbarlow Index: slime/ChangeLog diff -u slime/ChangeLog:1.47 slime/ChangeLog:1.48 --- slime/ChangeLog:1.47 Sun Oct 19 17:43:41 2003 +++ slime/ChangeLog Mon Oct 20 09:56:22 2003 @@ -1,3 +1,13 @@ +2003-10-20 Daniel Barlow + + * swank.lisp (*notes-database*): tyop fix + + * swank-sbcl.lisp (throw-to-toplevel): select TOPLEVEL restart + instead of throwing to a catch that no longer exists + + * slime.el: change some strings containing 'CMUCL' to more + backend-agnostic phrases + 2003-10-19 Helmut Eller * slime.el, swank-cmucl.lisp, swank.lisp: First shoot at input From dbarlow at common-lisp.net Mon Oct 20 13:56:36 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Mon, 20 Oct 2003 09:56:36 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7288 Modified Files: slime.el Log Message: Date: Mon Oct 20 09:56:36 2003 Author: dbarlow Index: slime/slime.el diff -u slime/slime.el:1.46 slime/slime.el:1.47 --- slime/slime.el:1.46 Sun Oct 19 17:36:21 2003 +++ slime/slime.el Mon Oct 20 09:56:36 2003 @@ -375,7 +375,7 @@ (= emacs-major-version 20)) ;; XEmacs truncates multi-line messages in the echo area. (defun slime-message (fmt &rest args) - (slime-display-message-or-view (apply #'format fmt args) "*CMUCL Note*")) + (slime-display-message-or-view (apply #'format fmt args) "*SLIME Note*")) (defun slime-message (fmt &rest args) (apply 'message fmt args))) @@ -476,7 +476,7 @@ nil nil initial-value))) -;;; CMUCL Setup: compiling and connecting to Swank +;;; Inferior CL Setup: compiling and connecting to Swank (defvar slime-connect-retry-timer nil "Timer object for connection retries.") @@ -577,14 +577,15 @@ ;;; Networking (defvar slime-net-process nil - "The process (socket) connected to CMUCL.") + "The process (socket) connected to the CL.") (defun slime-net-connect (host port) - "Establish a connection with CMUCL." + "Establish a connection with a CL." (condition-case nil (progn - (setq slime-net-process (open-network-stream "CMUCL" nil host port)) - (let ((buffer (slime-make-net-buffer "*cmucl-connection*"))) + (setq slime-net-process + (open-network-stream "SLIME Lisp" nil host port)) + (let ((buffer (slime-make-net-buffer "*cl-connection*"))) (set-process-buffer slime-net-process buffer) (set-process-filter slime-net-process 'slime-net-filter) (set-process-sentinel slime-net-process 'slime-net-sentinel) @@ -609,7 +610,7 @@ (slime-net-send `(,fun , at args))) (defun slime-net-send (sexp) - "Send a SEXP to CMUCL. + "Send a SEXP to inferior CL. This is the lowest level of communication. The sexp will be READ and EVAL'd by Lisp." (let* ((msg (format "%S\n" sexp)) @@ -1846,7 +1847,7 @@ (if (null plists) (message "No apropos matches for %S" string) (save-current-buffer - (slime-with-output-to-temp-buffer "*CMUCL Apropos*" + (slime-with-output-to-temp-buffer "*SLIME Apropos*" (set-buffer standard-output) (apropos-mode) (set-syntax-table lisp-mode-syntax-table) From dbarlow at common-lisp.net Mon Oct 20 13:56:44 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Mon, 20 Oct 2003 09:56:44 -0400 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7740 Modified Files: swank-sbcl.lisp Log Message: Date: Mon Oct 20 09:56:44 2003 Author: dbarlow Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.10 slime/swank-sbcl.lisp:1.11 --- slime/swank-sbcl.lisp:1.10 Sun Oct 19 17:40:28 2003 +++ slime/swank-sbcl.lisp Mon Oct 20 09:56:44 2003 @@ -39,7 +39,6 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (require 'sb-bsd-sockets) - (use-package "SB-BSD-SOCKETS") (require 'sb-introspect)) (declaim (optimize (debug 3))) @@ -603,9 +602,9 @@ (defslimefun sldb-abort () (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) -;;; from -openmcl (defslimefun throw-to-toplevel () - (throw 'slime-toplevel nil)) + (invoke-restart + (find 'sb-impl::toplevel *sldb-restarts* :key #'restart-name))) ;;; Local Variables: ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) From dbarlow at common-lisp.net Mon Oct 20 13:56:50 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Mon, 20 Oct 2003 09:56:50 -0400 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8126 Modified Files: swank.lisp Log Message: Date: Mon Oct 20 09:56:50 2003 Author: dbarlow Index: slime/swank.lisp diff -u slime/swank.lisp:1.39 slime/swank.lisp:1.40 --- slime/swank.lisp:1.39 Sun Oct 19 17:39:40 2003 +++ slime/swank.lisp Mon Oct 20 09:56:50 2003 @@ -216,7 +216,7 @@ (setf *previous-context* nil)) (defvar *notes-database* (make-hash-table :test #'equal) - "Database of recorded compiler notes/warnings/erros (keyed by filename). + "Database of recorded compiler notes/warnings/errors (keyed by filename). Each value is a list of (LOCATION SEVERITY MESSAGE CONTEXT) lists. LOCATION is a position in the source code (integer or source path). SEVERITY is one of :ERROR, :WARNING, :STYLE-WARNING and :NOTE. From lgorrie at common-lisp.net Mon Oct 20 15:09:11 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 20 Oct 2003 11:09:11 -0400 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18041 Modified Files: swank-cmucl.lisp Log Message: (clear-xref-info): Conditionalised xref:*who-is-called* and xref:*who-macroexpands* with #+CMU19. This makes SLIME compatible with CMUCL 18e, but also disables the `who-macroexpands' command in any CMUCL version that doesn't have the "19A" feature. Date: Mon Oct 20 11:09:11 2003 Author: lgorrie Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.9 slime/swank-cmucl.lisp:1.10 --- slime/swank-cmucl.lisp:1.9 Sun Oct 19 17:38:45 2003 +++ slime/swank-cmucl.lisp Mon Oct 20 11:09:10 2003 @@ -240,8 +240,8 @@ (let ((filename (parse-namestring namestring))) (when c:*record-xref-info* (dolist (db (list xref::*who-calls* - xref::*who-is-called* - xref::*who-macroexpands* + #+cmu19 xref::*who-is-called* + #+cmu19 xref::*who-macroexpands* xref::*who-references* xref::*who-binds* xref::*who-sets*)) @@ -312,6 +312,7 @@ "Return the places where the global variable VARIABLE is set." (xref-results-for-emacs (xref:who-sets variable))) +#+cmu19 (defslimefun who-macroexpands (macro) "Return the places where MACRO is expanded." (xref-results-for-emacs (xref:who-macroexpands macro))) From lgorrie at common-lisp.net Mon Oct 20 15:10:00 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 20 Oct 2003 11:10:00 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18198 Modified Files: ChangeLog Log Message: Date: Mon Oct 20 11:10:00 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.48 slime/ChangeLog:1.49 --- slime/ChangeLog:1.48 Mon Oct 20 09:56:22 2003 +++ slime/ChangeLog Mon Oct 20 11:10:00 2003 @@ -1,3 +1,11 @@ +2003-10-20 Luke Gorrie + + * swank-cmucl.lisp (clear-xref-info): Conditionalised + xref:*who-is-called* and xref:*who-macroexpands* with + #+CMU19. This makes SLIME compatible with CMUCL 18e, but also + disables the `who-macroexpands' command in any CMUCL version that + doesn't have the "19A" feature. + 2003-10-20 Daniel Barlow * swank.lisp (*notes-database*): tyop fix From lgorrie at common-lisp.net Mon Oct 20 15:12:54 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 20 Oct 2003 11:12:54 -0400 Subject: [slime-cvs] CVS update: slime/README Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19419 Modified Files: README Log Message: Updated: works with CMU18e, and with SBCL requires sb-introspect. Date: Mon Oct 20 11:12:54 2003 Author: lgorrie Index: slime/README diff -u slime/README:1.6 slime/README:1.7 --- slime/README:1.6 Wed Oct 15 12:23:44 2003 +++ slime/README Mon Oct 20 11:12:54 2003 @@ -18,10 +18,9 @@ (add-hook 'lisp-mode-hook (lambda () (slime-mode t))) Make sure your `inferior-lisp-program' is set to a compatible - version of Lisp. For CMUCL we currently require a post-18e - snapshot. If you use a non-CMUCL backend, you will need to customize - the elisp variable `slime-backend' and possibly - `slime-lisp-binary-extension' too. + version of Lisp. For CMUCL we currently require version 18e or + later. For SBCL we require the "sb-introspect" contrib, which exist + in the current CVS version. Use `M-x' slime to fire up and connect to an inferior Lisp. From heller at common-lisp.net Mon Oct 20 17:11:50 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 20 Oct 2003 13:11:50 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31470 Modified Files: slime.el Log Message: interactive-eval: Test case independent of *print-case*. Date: Mon Oct 20 13:11:50 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.47 slime/slime.el:1.48 --- slime/slime.el:1.47 Mon Oct 20 09:56:36 2003 +++ slime/slime.el Mon Oct 20 13:11:50 2003 @@ -1130,9 +1130,7 @@ (defun slime-compile-string (string start-offset) (slime-eval-async - `(swank:swank-compile-string ,string - ,(buffer-name) - ,start-offset) + `(swank:swank-compile-string ,string ,(buffer-name) ,start-offset) (slime-buffer-package) (slime-compilation-finished-continuation))) @@ -3131,13 +3129,13 @@ '(()) (let ((sldb-hook (lambda () (sldb-continue)))) (slime-interactive-eval - "(progn (cerror \"foo\" \"restart\") (cerror \"bar\" \"restart\") t)") + "(progn(cerror \"foo\" \"restart\")(cerror \"bar\" \"restart\")(+ 1 2))") (slime-sync-state-stack '(slime-idle-state) 5) (slime-check "Automaton is back in idle state." (slime-test-state-stack '(slime-idle-state))) (let ((message (current-message))) - (slime-check "Minibuffer contains: \"=> t\"" - (equal "=> t" message))))) + (slime-check "Minibuffer contains: \"=> 3\"" + (equal "=> 3" message))))) ;;; Portability library From heller at common-lisp.net Mon Oct 20 17:13:25 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 20 Oct 2003 13:13:25 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31957 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Mon Oct 20 13:13:25 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.49 slime/ChangeLog:1.50 --- slime/ChangeLog:1.49 Mon Oct 20 11:10:00 2003 +++ slime/ChangeLog Mon Oct 20 13:13:25 2003 @@ -1,3 +1,8 @@ +2003-10-20 Helmut Eller + + * slime.el (interactive-eval): Make test case independent of + *print-case*. + 2003-10-20 Luke Gorrie * swank-cmucl.lisp (clear-xref-info): Conditionalised From lgorrie at common-lisp.net Mon Oct 20 17:29:45 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 20 Oct 2003 13:29:45 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9924 Modified Files: slime.el Log Message: Updated test suite to work with the different backends: (find-definition): Lookup definitions in swank.lisp. (arglist): Lookup arglists of functions in swank.lisp. Date: Mon Oct 20 13:29:45 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.48 slime/slime.el:1.49 --- slime/slime.el:1.48 Mon Oct 20 13:11:50 2003 +++ slime/slime.el Mon Oct 20 13:29:45 2003 @@ -2905,20 +2905,24 @@ (setq slime-tests nil) (def-slime-test find-definition - (name expected-filename) - "Find the definition of a function or macro." - '((list "list.lisp") - (loop "loop.lisp") - (aref "array.lisp")) + (name buffer-package) + "Find the definition of a function or macro in swank.lisp." + '((read-from-emacs "SWANK") + (swank::read-from-emacs "CL-USER") + (swank:start-server "CL-USER")) + (switch-to-buffer "*scratch*") ; not buffer of definition (let ((orig-buffer (current-buffer)) - (orig-pos (point))) + (orig-pos (point)) + (enable-local-variables nil) ; don't get stuck on -*- eval: -*- + (slime-buffer-package buffer-package)) (slime-edit-fdefinition (symbol-name name)) ;; Postconditions - (slime-check ("Definition of `%S' is in %S." name expected-filename) + (slime-check ("Definition of `%S' is in swank.lisp." name) (string= (file-name-nondirectory (buffer-file-name)) - expected-filename)) + "swank.lisp")) (slime-check "Definition now at point." - (looking-at (format "(\\(defun\\|defmacro\\)\\s *%s\\s " name))) + (looking-at (format "(\\(defun\\|defmacro\\)\\s *%s\\s " + (slime-cl-symbol-name name)))) (slime-pop-find-definition-stack) (slime-check "Returning from definition restores original buffer/position." (and (eq orig-buffer (current-buffer)) @@ -2940,9 +2944,10 @@ (function-name expected-arglist) "Lookup the argument list for FUNCTION-NAME. Confirm that EXPECTED-ARGLIST is displayed." - '(("list" "(list &rest args)") - ("defun" "(defun &whole source name lambda-list &parse-body (body decls doc))") - ("cl::defun" "(cl::defun &whole source name lambda-list &parse-body (body decls doc))")) + '(("swank:start-server" + "(swank:start-server &optional (port server-port))") + ("swank::string-prefix-p" + "(swank::string-prefix-p s1 s2)")) (let ((arglist (slime-get-arglist function-name))) ; (slime-check ("Argument list %S is as expected." arglist) (string= expected-arglist arglist)))) From lgorrie at common-lisp.net Mon Oct 20 17:29:57 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 20 Oct 2003 13:29:57 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10005 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Mon Oct 20 13:29:57 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.50 slime/ChangeLog:1.51 --- slime/ChangeLog:1.50 Mon Oct 20 13:13:25 2003 +++ slime/ChangeLog Mon Oct 20 13:29:57 2003 @@ -1,3 +1,9 @@ +2003-10-20 Luke Gorrie + + * slime.el: Updated test suite to work with the different backends: + (find-definition): Lookup definitions in swank.lisp. + (arglist): Lookup arglists of functions in swank.lisp. + 2003-10-20 Helmut Eller * slime.el (interactive-eval): Make test case independent of From lgorrie at common-lisp.net Mon Oct 20 17:36:23 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 20 Oct 2003 13:36:23 -0400 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14026 Modified Files: swank.lisp Log Message: (completions): Slight change of semantics: when a prefix-designator is package-qualified, like "swank:", only match symbols whose home-package matches the one given - ignore inherited symbols. Date: Mon Oct 20 13:36:22 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.40 slime/swank.lisp:1.41 --- slime/swank.lisp:1.40 Mon Oct 20 09:56:50 2003 +++ slime/swank.lisp Mon Oct 20 13:36:22 2003 @@ -314,37 +314,54 @@ result strings are also not qualified and are considered relative to DEFAULT-PACKAGE-NAME. All symbols accessible in the package are considered." - (flet ((parse-designator (string) - (values (let ((pos (position #\: string :from-end t))) - (if pos (subseq string (1+ pos)) string)) - (let ((pos (position #\: string))) - (if pos (subseq string 0 pos) nil)) - (search "::" string)))) - (multiple-value-bind (name package-name internal) (parse-designator string) - (let ((completions nil) - (package (find-package - (string-upcase (cond ((equal package-name "") "KEYWORD") - (package-name) - (default-package-name)))))) - (when package - (do-symbols (symbol package) - (when (and (string-prefix-p name (symbol-name symbol)) - (or internal - (not package-name) - (symbol-external-p symbol))) - (push symbol completions)))) - (let ((*print-case* (if (find-if #'upper-case-p string) - :upcase :downcase)) - (*package* package)) - (mapcar (lambda (s) - (cond (internal (format nil "~A::~A" package-name s)) - (package-name (format nil "~A:~A" package-name s)) - (t (format nil "~A" s)))) - completions)))))) + (multiple-value-bind (name package-name internal-p) + (parse-symbol-designator string) + (let ((completions nil) + (package (find-package + (string-upcase (cond ((equal package-name "") "KEYWORD") + (package-name) + (default-package-name)))))) + (flet ((package-matches (symbol-package) + ;; True if SYMBOL-PACKAGE is valid for the completion. + ;; When the designator includes an explicit package + ;; prefix, only symbols in that package are considered. + (or (null package-name) + (eq symbol-package package))) + (visible-p (symbol) + ;; True if SYMBOL is visible for this completion. + (or internal-p + (symbol-external-p symbol)))) + (when package + (do-symbols (symbol package) + (when (and (string-prefix-p name (symbol-name symbol)) + (package-matches (symbol-package symbol)) + (visible-p symbol)) + (push symbol completions))))) + (let ((*print-case* (if (find-if #'upper-case-p string) + :upcase :downcase)) + (*package* package)) + (mapcar (lambda (s) + (cond (internal-p (format nil "~A::~A" package-name s)) + (package-name (format nil "~A:~A" package-name s)) + (t (format nil "~A" s)))) + completions))))) -(defun symbol-external-p (s) +(defun parse-symbol-designator (string) + "Parse STRING as a symbol designator. +Return three values: + SYMBOL-NAME + PACKAGE-NAME, or nil if the designator does not include an explicit package. + INTERNAL-P, if the symbol is qualified with `::'." + (values (let ((pos (position #\: string :from-end t))) + (if pos (subseq string (1+ pos)) string)) + (let ((pos (position #\: string))) + (if pos (subseq string 0 pos) nil)) + (search "::" string))) + +(defun symbol-external-p (symbol) + "True if SYMBOL is external in its home package." (multiple-value-bind (_ status) - (find-symbol (symbol-name s) (symbol-package s)) + (find-symbol (symbol-name symbol) (symbol-package symbol)) (declare (ignore _)) (eq status :external))) From lgorrie at common-lisp.net Mon Oct 20 17:36:32 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 20 Oct 2003 13:36:32 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14070 Modified Files: ChangeLog Log Message: Date: Mon Oct 20 13:36:32 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.51 slime/ChangeLog:1.52 --- slime/ChangeLog:1.51 Mon Oct 20 13:29:57 2003 +++ slime/ChangeLog Mon Oct 20 13:36:32 2003 @@ -1,5 +1,10 @@ 2003-10-20 Luke Gorrie + * swank.lisp (completions): Slight change of semantics: when a + prefix-designator is package-qualified, like "swank:", only match + symbols whose home-package matches the one given - ignore + inherited symbols. + * slime.el: Updated test suite to work with the different backends: (find-definition): Lookup definitions in swank.lisp. (arglist): Lookup arglists of functions in swank.lisp. From lgorrie at common-lisp.net Mon Oct 20 17:51:45 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 20 Oct 2003 13:51:45 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23550 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Mon Oct 20 13:51:44 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.52 slime/ChangeLog:1.53 --- slime/ChangeLog:1.52 Mon Oct 20 13:36:32 2003 +++ slime/ChangeLog Mon Oct 20 13:51:44 2003 @@ -20,7 +20,8 @@ xref:*who-is-called* and xref:*who-macroexpands* with #+CMU19. This makes SLIME compatible with CMUCL 18e, but also disables the `who-macroexpands' command in any CMUCL version that - doesn't have the "19A" feature. + doesn't have the "19A" feature (which does break the command in + some snapshot builds that can actually support it). 2003-10-20 Daniel Barlow From lgorrie at common-lisp.net Tue Oct 21 10:47:41 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 21 Oct 2003 06:47:41 -0400 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18467 Modified Files: swank.lisp Log Message: (completions): Fixed semantics: should now consider only/all completions that would not cause a read-error due to symbol visibility. Also avoiding duplicates, and sorting the results as with apropos. Date: Tue Oct 21 06:47:40 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.41 slime/swank.lisp:1.42 --- slime/swank.lisp:1.41 Mon Oct 20 13:36:22 2003 +++ slime/swank.lisp Tue Oct 21 06:47:40 2003 @@ -312,8 +312,13 @@ The result is a list of strings. If STRING is package qualified the result list will also be qualified. If string is non-qualified the result strings are also not qualified and are considered relative to -DEFAULT-PACKAGE-NAME. All symbols accessible in the package are -considered." +DEFAULT-PACKAGE-NAME. + +The way symbols are matched depends on the symbol designator's +format. The cases are as follows: + FOO - Symbols with matching prefix and accessible in the buffer package. + PKG:FOO - Symbols with matching prefix and external in package PKG. + PKG::FOO - Symbols with matching prefix and accessible in package PKG." (multiple-value-bind (name package-name internal-p) (parse-symbol-designator string) (let ((completions nil) @@ -321,21 +326,13 @@ (string-upcase (cond ((equal package-name "") "KEYWORD") (package-name) (default-package-name)))))) - (flet ((package-matches (symbol-package) - ;; True if SYMBOL-PACKAGE is valid for the completion. - ;; When the designator includes an explicit package - ;; prefix, only symbols in that package are considered. - (or (null package-name) - (eq symbol-package package))) - (visible-p (symbol) - ;; True if SYMBOL is visible for this completion. - (or internal-p - (symbol-external-p symbol)))) + (flet ((symbol-matches-p (symbol) + (and (string-prefix-p name (symbol-name symbol)) + (or (or internal-p (null package-name)) + (symbol-external-p symbol package))))) (when package (do-symbols (symbol package) - (when (and (string-prefix-p name (symbol-name symbol)) - (package-matches (symbol-package symbol)) - (visible-p symbol)) + (when (symbol-matches-p symbol) (push symbol completions))))) (let ((*print-case* (if (find-if #'upper-case-p string) :upcase :downcase)) @@ -344,7 +341,10 @@ (cond (internal-p (format nil "~A::~A" package-name s)) (package-name (format nil "~A:~A" package-name s)) (t (format nil "~A" s)))) - completions))))) + ;; DO-SYMBOLS can consider the same symbol more than + ;; once, so remove duplicates. + (remove-duplicates (sort completions + #'present-symbol-before-p))))))) (defun parse-symbol-designator (string) "Parse STRING as a symbol designator. @@ -358,10 +358,11 @@ (if pos (subseq string 0 pos) nil)) (search "::" string))) -(defun symbol-external-p (symbol) - "True if SYMBOL is external in its home package." +(defun symbol-external-p (symbol &optional (package (symbol-package symbol))) + "True if SYMBOL is external in PACKAGE. +If PACKAGE is not specified, the home package of SYMBOL is used." (multiple-value-bind (_ status) - (find-symbol (symbol-name symbol) (symbol-package symbol)) + (find-symbol (symbol-name symbol) (or package (symbol-package symbol))) (declare (ignore _)) (eq status :external))) @@ -393,15 +394,13 @@ that symbols accessible in the current package go first." (flet ((accessible (s) (find-symbol (symbol-name s) *buffer-package*))) - (let ((pa (symbol-package a)) - (pb (symbol-package b))) - (cond ((or (eq pa pb) - (and (accessible a) (accessible b))) - (string< (symbol-name a) (symbol-name b))) - ((accessible a) t) - ((accessible b) nil) - (t - (string< (package-name pa) (package-name pb))))))) + (cond ((and (accessible a) (accessible b)) + (string< (symbol-name a) (symbol-name b))) + ((accessible a) t) + ((accessible b) nil) + (t + (string< (package-name (symbol-package a)) + (package-name (symbol-package b))))))) ;;; From lgorrie at common-lisp.net Tue Oct 21 10:49:05 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 21 Oct 2003 06:49:05 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19379 Modified Files: ChangeLog Log Message: Date: Tue Oct 21 06:49:02 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.53 slime/ChangeLog:1.54 --- slime/ChangeLog:1.53 Mon Oct 20 13:51:44 2003 +++ slime/ChangeLog Tue Oct 21 06:48:59 2003 @@ -1,3 +1,10 @@ +2003-10-21 Luke Gorrie + + * swank.lisp (completions): Fixed semantics: should now consider + only/all completions that would not cause a read-error due to + symbol visibility. Also avoiding duplicates, and sorting the + results as with apropos. + 2003-10-20 Luke Gorrie * swank.lisp (completions): Slight change of semantics: when a From lgorrie at common-lisp.net Tue Oct 21 10:59:04 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 21 Oct 2003 06:59:04 -0400 Subject: [slime-cvs] CVS update: slime/swank.lisp slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30593 Modified Files: swank.lisp ChangeLog Log Message: Now sorting completions on symbol-name instead of `present-symbol-before-p' Date: Tue Oct 21 06:59:04 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.42 slime/swank.lisp:1.43 --- slime/swank.lisp:1.42 Tue Oct 21 06:47:40 2003 +++ slime/swank.lisp Tue Oct 21 06:59:04 2003 @@ -343,8 +343,8 @@ (t (format nil "~A" s)))) ;; DO-SYMBOLS can consider the same symbol more than ;; once, so remove duplicates. - (remove-duplicates (sort completions - #'present-symbol-before-p))))))) + (remove-duplicates (sort completions #'string< + :key #'symbol-name))))))) (defun parse-symbol-designator (string) "Parse STRING as a symbol designator. Index: slime/ChangeLog diff -u slime/ChangeLog:1.54 slime/ChangeLog:1.55 --- slime/ChangeLog:1.54 Tue Oct 21 06:48:59 2003 +++ slime/ChangeLog Tue Oct 21 06:59:04 2003 @@ -2,8 +2,8 @@ * swank.lisp (completions): Fixed semantics: should now consider only/all completions that would not cause a read-error due to - symbol visibility. Also avoiding duplicates, and sorting the - results as with apropos. + symbol visibility. Also avoiding duplicates and sorting on + symbol-name. 2003-10-20 Luke Gorrie From lgorrie at common-lisp.net Tue Oct 21 19:05:39 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 21 Oct 2003 15:05:39 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30033 Modified Files: slime.el Log Message: (inferior-slime-mode): New minor mode for use with `inferior-lisp-mode'. Defines a subset of the `slime-mode' keys which don't clash with comint (e.g. doesn't bind M-{p,n}). (slime-keys): List of keybinding specifications. Date: Tue Oct 21 15:05:07 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.49 slime/slime.el:1.50 --- slime/slime.el:1.49 Mon Oct 20 13:29:45 2003 +++ slime/slime.el Tue Oct 21 15:04:47 2003 @@ -148,11 +148,11 @@ :group 'slime) -;;; Minor mode +;;; Minor modes (define-minor-mode slime-mode "\\ -SLIME: The Superior Lisp Interaction Mode, Extended (minor-mode). +SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode). Commands to compile the current buffer's source file and visually highlight any resulting compiler notes and warnings: @@ -195,49 +195,21 @@ \\{slime-mode-map}" nil nil - '((" " . slime-space) - ("\M-p" . slime-previous-note) - ("\M-n" . slime-next-note) - ("\C-c\M-c" . slime-remove-notes) - ("\C-c\C-k" . slime-compile-and-load-file) - ("\C-c\M-k" . slime-compile-file) - ("\C-c\C-c" . slime-compile-defun) - ("\C-c\C-l" . slime-load-file) - ;; Multiple bindings for completion, since M-TAB is often taken by - ;; the window manager. - ("\M-\C-i" . slime-complete-symbol) - ("\C-c\C-i" . slime-complete-symbol) - ("\M-." . slime-edit-fdefinition) - ("\M-," . slime-pop-find-definition-stack) - ("\C-x\C-e" . slime-eval-last-expression) - ("\C-c\C-p" . slime-pprint-eval-last-expression) - ("\M-\C-x" . slime-eval-defun) - ("\C-c:" . slime-interactive-eval) - ("\C-c\C-z" . slime-switch-to-output-buffer) - ("\C-c\C-d" . slime-describe-symbol) - ("\C-c\M-d" . slime-disassemble-symbol) - ("\C-c\C-t" . slime-toggle-trace-fdefinition) - ("\C-c\C-a" . slime-apropos) - ("\C-c\M-a" . slime-apropos-all) - ([(control c) (control m)] . slime-macroexpand-1) - ([(control c) (meta m)] . slime-macroexpand-all) - ("\C-c\C-g" . slime-interrupt) - ("\C-c\M-g" . slime-quit) - ("\C-c\M-0" . slime-restore-window-configuration) - ("\C-c\C-h" . hyperspec-lookup) - ("\C-c\C-wc" . slime-who-calls) - ("\C-c\C-wr" . slime-who-references) - ("\C-c\C-wb" . slime-who-binds) - ("\C-c\C-ws" . slime-who-sets) - ("\C-c\C-wm" . slime-who-macroexpands) - ;; Not sure which binding is best yet, so both for now. - ([(control meta ?\.)] . slime-next-location) - ("\C-c\C- " . slime-next-location) - ("\C-c~" . slime-sync-package-and-default-directory) - ("\C-c\C-i" . slime-inspect) - ("\C-c<" . slime-list-callers) - ("\C-c>" . slime-list-callees) - )) + ;; Fake binding to coax `define-minor-mode' to create the keymap + '((" " 'undefined))) + +(define-minor-mode inferior-slime-mode + "\\ +Inferior SLIME mode: The Inferior Superior Lisp Mode for Emacs. + +This mode is intended for use with `inferior-lisp-mode'. It provides a +subset of the bindings from `slime-mode'. + +\\{inferior-slime-mode-map}" + nil + nil + ;; Fake binding to coax `define-minor-mode' to create the keymap + '((" " 'undefined))) ;; Setup the mode-line to say when we're in slime-mode, and which CL ;; package we think the current buffer belongs to. @@ -247,6 +219,82 @@ ((slime-buffer-package (":" slime-buffer-package) "") slime-state-name)))) +(add-to-list 'minor-mode-alist + '(inferior-slime-mode + (" Inf-Slime" + ((slime-buffer-package (":" slime-buffer-package) "") + slime-state-name)))) + +;; Key bindings. See `slime-define-key' below for keyword meanings. +(defvar slime-keys + '(;; Compiler notes + ("\M-p" slime-previous-note) + ("\M-n" slime-next-note) + ("\M-c" slime-remove-notes :prefixed t) + ("\C-k" slime-compile-and-load-file :prefixed t) + ("\M-k" slime-compile-file :prefixed t) + ("\C-c" slime-compile-defun :prefixed t) + ("\C-l" slime-load-file :prefixed t) + ;; Editing/navigating + ;; NB: Existing `slime-inspect' binding of \C-c\C-i (i.e. C-TAB) + ;; clashes with completion! Need a new key for one of them. + ("\M-\C-i" slime-complete-symbol :inferior t) + ("\C-i" slime-complete-symbol :prefixed t :inferior t) + ("\M-." slime-edit-fdefinition :inferior t) + ("\M-," slime-pop-find-definition-stack :inferior t) + ;; Evaluating + ("\C-x\C-e" slime-eval-last-expression :inferior t) + ("\C-p" slime-pprint-eval-last-expression :prefixed t :inferior t) + ("\C-\M-x" slime-eval-defun) + (":" slime-interactive-eval :prefixed t) + ("\C-z" slime-switch-to-output-buffer :prefixed t) + ("\C-g" slime-interrupt :prefixed t :inferior t) + ("\M-g" slime-quit :prefixed t :inferior t) + ;; Documentation + (" " slime-space :inferior t) + ("\C-d" slime-describe-symbol :prefixed t :inferior t) + ("\M-d" slime-disassemble-symbol :prefixed t :inferior t) + ("\C-t" slime-toggle-trace-fdefinition :prefixed t) + ("\C-a" slime-apropos :prefixed t :inferior t) + ("\M-a" slime-apropos-all :prefixed t :inferior t) + ("\C-m" slime-macroexpand-1 :prefixed t :inferior t) + ("\M-m" slime-macroexpand-all :prefixed t :inferior t) + ("\M-0" slime-restore-window-configuration :prefixed t :inferior t) + ("\C-h" hyperspec-lookup :prefixed t :inferior t) + ([(control meta ?\.)] slime-next-location :inferior t) + ("\C- " slime-next-location :prefixed t :inferior t) + ("~" slime-sync-package-and-default-directory :prefixed t :inferior t) + ;; Cross reference + ("\C-wc" slime-who-calls :prefixed t :inferior t) + ("\C-wr" slime-who-references :prefixed t :inferior t) + ("\C-wb" slime-who-binds :prefixed t :inferior t) + ("\C-ws" slime-who-sets :prefixed t :inferior t) + ("\C-wm" slime-who-macroexpands :prefixed t :inferior t) + ("<" slime-list-callers :prefixed t :inferior t) + (">" slime-list-callees :prefixed t :inferior t))) + +;; Maybe a good idea, maybe not.. +(defvar slime-prefix-key "\C-c" + "The prefix key to use in SLIME keybinding sequences.") + +(defun* slime-define-key (key command &key prefixed inferior) + "Define a keybinding of KEY for COMMAND. +If PREFIXED is non-nil, `slime-prefix-key' is prepended to KEY. +If INFERIOR is non-nil, the key is also bound for `inferior-slime-mode'." + (when prefixed + (setq key (concat slime-prefix-key key))) + (define-key slime-mode-map key command) + (when inferior + (define-key inferior-slime-mode-map key command))) + +(defun slime-init-keymaps () + "(Re)initialize the keymaps for `slime-mode' and `inferior-slime-mode'." + (interactive) + (dolist (binding-spec slime-keys) + (apply #'slime-define-key binding-spec))) + +(slime-init-keymaps) + ;;; Setup initial `slime-mode' hooks @@ -325,9 +373,10 @@ (defun slime-find-buffer-package () "Figure out which Lisp package the current buffer is associated with." (save-excursion - (when (let ((case-fold-search t)) - (re-search-backward "^(\\(cl:\\|common-lisp:\\)?in-package\\>" - nil t)) + (when (let ((case-fold-search t) + (regexp "^(\\(cl:\\|common-lisp:\\)?in-package\\>")) + (or (re-search-backward regexp nil t) + (re-search-forward regexp nil t))) (goto-char (match-end 0)) (skip-chars-forward " \n\t\f\r#:") (let ((pkg (condition-case nil (read (current-buffer)) (error nil )))) From lgorrie at common-lisp.net Tue Oct 21 19:18:59 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 21 Oct 2003 15:18:59 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5805 Modified Files: ChangeLog Log Message: Date: Tue Oct 21 15:18:34 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.55 slime/ChangeLog:1.56 --- slime/ChangeLog:1.55 Tue Oct 21 06:59:04 2003 +++ slime/ChangeLog Tue Oct 21 15:18:19 2003 @@ -1,5 +1,10 @@ 2003-10-21 Luke Gorrie + * slime.el (inferior-slime-mode): New minor mode for use with + `inferior-lisp-mode'. Defines a subset of the `slime-mode' keys + which don't clash with comint (e.g. doesn't bind M-{p,n}). + (slime-keys): List of keybinding specifications. + * swank.lisp (completions): Fixed semantics: should now consider only/all completions that would not cause a read-error due to symbol visibility. Also avoiding duplicates and sorting on From lgorrie at common-lisp.net Tue Oct 21 19:31:33 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 21 Oct 2003 15:31:33 -0400 Subject: [slime-cvs] CVS update: slime/README Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13860 Modified Files: README Log Message: Date: Tue Oct 21 15:30:50 2003 Author: lgorrie Index: slime/README diff -u slime/README:1.7 slime/README:1.8 --- slime/README:1.7 Mon Oct 20 11:12:54 2003 +++ slime/README Tue Oct 21 15:29:52 2003 @@ -16,6 +16,7 @@ (add-to-list 'load-path "/the/path/to/this/directory") (require 'slime) (add-hook 'lisp-mode-hook (lambda () (slime-mode t))) + (add-hook 'inferior-lisp-mode-hook (lambda () (inferior-slime-mode t))) Make sure your `inferior-lisp-program' is set to a compatible version of Lisp. For CMUCL we currently require version 18e or From lgorrie at common-lisp.net Tue Oct 21 19:38:24 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 21 Oct 2003 15:38:24 -0400 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17965 Modified Files: swank-sbcl.lisp Log Message: (swank-compile-string): Include only one :SOURCE-PATH attribute in the plist, and replace the front element with a 0 (fixes a problem probably due to recent hacks to the elisp source-path lookups). Date: Tue Oct 21 15:37:21 2003 Author: lgorrie Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.11 slime/swank-sbcl.lisp:1.12 --- slime/swank-sbcl.lisp:1.11 Mon Oct 20 09:56:44 2003 +++ slime/swank-sbcl.lisp Tue Oct 21 15:36:23 2003 @@ -287,9 +287,10 @@ (setf *compiler-notes* (loop for n in *compiler-notes* for sp = (getf n :source-path) - do (setf (getf n :source-path) (cdr sp)) + ;; account for the added lambda, replace leading + ;; position with 0 + do (setf (getf n :source-path) (cons 0 (cddr sp))) collect (list* :buffername buffer - :source-path (cdr sp) :buffer-offset start n)))))))) From lgorrie at common-lisp.net Tue Oct 21 19:45:58 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 21 Oct 2003 15:45:58 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv24922 Modified Files: ChangeLog Log Message: Date: Tue Oct 21 15:45:49 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.56 slime/ChangeLog:1.57 --- slime/ChangeLog:1.56 Tue Oct 21 15:18:19 2003 +++ slime/ChangeLog Tue Oct 21 15:45:46 2003 @@ -1,9 +1,16 @@ 2003-10-21 Luke Gorrie + * swank-sbcl.lisp (swank-compile-string): Include only one + :SOURCE-PATH attribute in the plist, and replace the front element + with a 0 (fixes a problem probably due to recent hacks to the + elisp source-path lookups). + * slime.el (inferior-slime-mode): New minor mode for use with `inferior-lisp-mode'. Defines a subset of the `slime-mode' keys which don't clash with comint (e.g. doesn't bind M-{p,n}). (slime-keys): List of keybinding specifications. + (slime-find-buffer-package): If we don't find the "(in-package" by + searching backwards, then try forwards too. * swank.lisp (completions): Fixed semantics: should now consider only/all completions that would not cause a read-error due to From lgorrie at common-lisp.net Tue Oct 21 20:38:51 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 21 Oct 2003 16:38:51 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29390 Modified Files: slime.el Log Message: outline-mode heading tweak. Date: Tue Oct 21 16:38:50 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.50 slime/slime.el:1.51 --- slime/slime.el:1.50 Tue Oct 21 15:04:47 2003 +++ slime/slime.el Tue Oct 21 16:38:49 2003 @@ -225,7 +225,10 @@ ((slime-buffer-package (":" slime-buffer-package) "") slime-state-name)))) -;; Key bindings. See `slime-define-key' below for keyword meanings. + +;;;;; Key bindings + +;; See `slime-define-key' below for keyword meanings. (defvar slime-keys '(;; Compiler notes ("\M-p" slime-previous-note) From lgorrie at common-lisp.net Tue Oct 21 20:51:45 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 21 Oct 2003 16:51:45 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6490 Modified Files: slime.el Log Message: (slime-space): Don't give an error when not connected, to avoid feeping. Date: Tue Oct 21 16:51:45 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.51 slime/slime.el:1.52 --- slime/slime.el:1.51 Tue Oct 21 16:38:49 2003 +++ slime/slime.el Tue Oct 21 16:51:44 2003 @@ -1551,9 +1551,10 @@ Designed to be bound to the SPC key." (interactive) (insert " ") - (unless (slime-busy-p) - (when (slime-function-called-at-point/line) - (slime-arglist (symbol-name (slime-function-called-at-point/line)))))) + (when (and (slime-connected-p) + (not (slime-busy-p)) + (slime-function-called-at-point/line)) + (slime-arglist (symbol-name (slime-function-called-at-point/line))))) (defun slime-arglist (symbol-name) "Show the argument list for the nearest function call, if any." From lgorrie at common-lisp.net Tue Oct 21 20:52:04 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 21 Oct 2003 16:52:04 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6574 Modified Files: ChangeLog Log Message: Date: Tue Oct 21 16:51:58 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.57 slime/ChangeLog:1.58 --- slime/ChangeLog:1.57 Tue Oct 21 15:45:46 2003 +++ slime/ChangeLog Tue Oct 21 16:51:58 2003 @@ -1,5 +1,8 @@ 2003-10-21 Luke Gorrie + * slime.el (slime-space): Don't give an error when not connected, + to avoid feeping. + * swank-sbcl.lisp (swank-compile-string): Include only one :SOURCE-PATH attribute in the plist, and replace the front element with a 0 (fixes a problem probably due to recent hacks to the From lgorrie at common-lisp.net Wed Oct 22 17:48:11 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 22 Oct 2003 13:48:11 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26954 Modified Files: slime.el Log Message: (slime-space): Now allows one to insert several spaces with a prefix argument. (Patch from Hannu Koivisto) Date: Wed Oct 22 13:48:11 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.52 slime/slime.el:1.53 --- slime/slime.el:1.52 Tue Oct 21 16:51:44 2003 +++ slime/slime.el Wed Oct 22 13:48:11 2003 @@ -1546,11 +1546,12 @@ ;;; Arglist Display -(defun slime-space () +(defun slime-space (n) "Insert a space and print some relevant information (function arglist). -Designed to be bound to the SPC key." - (interactive) - (insert " ") +Designed to be bound to the SPC key. Prefix argument can be used to insert +more than one space." + (interactive "p") + (self-insert-command n) (when (and (slime-connected-p) (not (slime-busy-p)) (slime-function-called-at-point/line)) From lgorrie at common-lisp.net Wed Oct 22 17:54:33 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 22 Oct 2003 13:54:33 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30323 Modified Files: ChangeLog Log Message: Date: Wed Oct 22 13:54:33 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.58 slime/ChangeLog:1.59 --- slime/ChangeLog:1.58 Tue Oct 21 16:51:58 2003 +++ slime/ChangeLog Wed Oct 22 13:54:32 2003 @@ -1,3 +1,8 @@ +2003-10-22 Hannu Koivisto + + * slime.el (slime-space): Now allows one to insert several spaces + with a prefix argument. + 2003-10-21 Luke Gorrie * slime.el (slime-space): Don't give an error when not connected, From lgorrie at common-lisp.net Wed Oct 22 19:04:52 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 22 Oct 2003 15:04:52 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7722 Modified Files: slime.el Log Message: (slime): With a prefix argument, prompt for the port number to use for communication with Lisp. This is remembered for future connections. Date: Wed Oct 22 15:04:51 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.53 slime/slime.el:1.54 --- slime/slime.el:1.53 Wed Oct 22 13:48:11 2003 +++ slime/slime.el Wed Oct 22 15:04:51 2003 @@ -534,13 +534,26 @@ "Timer object for connection retries.") (defun slime () - "Start an inferior^_superior Lisp and connect to its Swank server." + "Start an inferior^_superior Lisp and connect to its Swank server. +With a prefix argument, prompt for the port number for Lisp +communication. The port is remembered for future connections." (interactive) + (when current-prefix-arg + (slime-read-and-update-swank-port)) (when (slime-connected-p) (slime-disconnect)) (slime-maybe-start-lisp) (slime-connect "localhost" slime-swank-port)) +(defun slime-read-and-update-swank-port () + "Prompt the user for the port number to use for Lisp communication." + (let* ((port-string (format "%S" slime-swank-port)) + (new-port-string (read-from-minibuffer "SLIME Port: " port-string)) + (new-port (read new-port-string))) + (if (integerp new-port) + (setq slime-swank-port new-port) + (error "Not a valid port: %S" new-port-string)))) + (defun slime-maybe-start-lisp () "Start an inferior lisp unless one is already running." (unless (get-buffer "*inferior-lisp*") From lgorrie at common-lisp.net Wed Oct 22 19:05:58 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 22 Oct 2003 15:05:58 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8354 Modified Files: ChangeLog Log Message: Date: Wed Oct 22 15:05:58 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.59 slime/ChangeLog:1.60 --- slime/ChangeLog:1.59 Wed Oct 22 13:54:32 2003 +++ slime/ChangeLog Wed Oct 22 15:05:58 2003 @@ -1,3 +1,9 @@ +2003-10-22 Luke Gorrie + + * slime.el (slime): With a prefix argument, prompt for the port + number to use for communication with Lisp. This is remembered for + future connections. + 2003-10-22 Hannu Koivisto * slime.el (slime-space): Now allows one to insert several spaces From heller at common-lisp.net Wed Oct 22 21:03:25 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 22 Oct 2003 17:03:25 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12728 Modified Files: slime.el Log Message: slime-keys: Add :sldb keyword for key useful in the debugger. (slime-init-keymaps): Allow allow :sldb keyword. inferior-lisp-mode-hook: Display the inf-lisp buffer if there is some output. (slime-process-available-input): Start a timer to process any remaining input. (slime-dispatch-event): The timer should take care of any lost input. So don't process the available input here. Remove the process-input argument. (slime-push-state, slime-pop-state, slime-activate-state, slime-idle-state, slime-evaluating-state): Update callers. (slime-debugging-state): Remove the unwind-protect in the :debug-return clause. Should not be necessary. sldb-mode-map: Define more slime-mode keys. (slime-time<, slime-time-add): Removed. Emacs-21 has equivalent time functions. (slime-sync-state-stack): Use Emacs-21 time-date functions. (seconds-to-time, time-less-p, time-add): Compatibility defuns. Date: Wed Oct 22 17:03:25 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.54 slime/slime.el:1.55 --- slime/slime.el:1.54 Wed Oct 22 15:04:51 2003 +++ slime/slime.el Wed Oct 22 17:03:24 2003 @@ -243,38 +243,38 @@ ;; clashes with completion! Need a new key for one of them. ("\M-\C-i" slime-complete-symbol :inferior t) ("\C-i" slime-complete-symbol :prefixed t :inferior t) - ("\M-." slime-edit-fdefinition :inferior t) - ("\M-," slime-pop-find-definition-stack :inferior t) + ("\M-." slime-edit-fdefinition :inferior t :sldb t) + ("\M-," slime-pop-find-definition-stack :inferior t :sldb t) ;; Evaluating ("\C-x\C-e" slime-eval-last-expression :inferior t) ("\C-p" slime-pprint-eval-last-expression :prefixed t :inferior t) ("\C-\M-x" slime-eval-defun) - (":" slime-interactive-eval :prefixed t) - ("\C-z" slime-switch-to-output-buffer :prefixed t) - ("\C-g" slime-interrupt :prefixed t :inferior t) - ("\M-g" slime-quit :prefixed t :inferior t) + (":" slime-interactive-eval :prefixed t :sldb t) + ("\C-z" slime-switch-to-output-buffer :prefixed t :sldb t) + ("\C-g" slime-interrupt :prefixed t :inferior t :sldb t) + ("\M-g" slime-quit :prefixed t :inferior t :sldb t) ;; Documentation (" " slime-space :inferior t) - ("\C-d" slime-describe-symbol :prefixed t :inferior t) - ("\M-d" slime-disassemble-symbol :prefixed t :inferior t) - ("\C-t" slime-toggle-trace-fdefinition :prefixed t) - ("\C-a" slime-apropos :prefixed t :inferior t) - ("\M-a" slime-apropos-all :prefixed t :inferior t) + ("\C-d" slime-describe-symbol :prefixed t :inferior t :sldb t) + ("\M-d" slime-disassemble-symbol :prefixed t :inferior t :sldb t) + ("\C-t" slime-toggle-trace-fdefinition :prefixed t :sldb t) + ("\C-a" slime-apropos :prefixed t :inferior t :sldb t) + ("\M-a" slime-apropos-all :prefixed t :inferior t :sldb t) ("\C-m" slime-macroexpand-1 :prefixed t :inferior t) ("\M-m" slime-macroexpand-all :prefixed t :inferior t) ("\M-0" slime-restore-window-configuration :prefixed t :inferior t) - ("\C-h" hyperspec-lookup :prefixed t :inferior t) + ("\C-h" hyperspec-lookup :prefixed t :inferior t :sldb t) ([(control meta ?\.)] slime-next-location :inferior t) ("\C- " slime-next-location :prefixed t :inferior t) ("~" slime-sync-package-and-default-directory :prefixed t :inferior t) ;; Cross reference - ("\C-wc" slime-who-calls :prefixed t :inferior t) - ("\C-wr" slime-who-references :prefixed t :inferior t) - ("\C-wb" slime-who-binds :prefixed t :inferior t) - ("\C-ws" slime-who-sets :prefixed t :inferior t) - ("\C-wm" slime-who-macroexpands :prefixed t :inferior t) - ("<" slime-list-callers :prefixed t :inferior t) - (">" slime-list-callees :prefixed t :inferior t))) + ("\C-wc" slime-who-calls :prefixed t :inferior t :sldb t) + ("\C-wr" slime-who-references :prefixed t :inferior t :sldb t) + ("\C-wb" slime-who-binds :prefixed t :inferior t :sldb t) + ("\C-ws" slime-who-sets :prefixed t :inferior t :sldb t) + ("\C-wm" slime-who-macroexpands :prefixed t :inferior t :sldb t) + ("<" slime-list-callers :prefixed t :inferior t :sldb t) + (">" slime-list-callees :prefixed t :inferior t :sldb t))) ;; Maybe a good idea, maybe not.. (defvar slime-prefix-key "\C-c" @@ -293,8 +293,8 @@ (defun slime-init-keymaps () "(Re)initialize the keymaps for `slime-mode' and `inferior-slime-mode'." (interactive) - (dolist (binding-spec slime-keys) - (apply #'slime-define-key binding-spec))) + (loop for (key command . keys) in slime-keys + do (apply #'slime-define-key key command :allow-other-keys t keys))) (slime-init-keymaps) @@ -325,6 +325,15 @@ (add-hook 'slime-mode-hook 'slime-setup-command-hooks) (add-hook 'slime-mode-hook 'slime-buffer-package) +(add-hook 'inferior-lisp-mode-hook + (lambda () + (add-to-list + (make-local-variable 'comint-output-filter-functions) + (lambda (string) + (unless (get-buffer-window (current-buffer)) + (display-buffer (current-buffer) t)) + (comint-postoutput-scroll-to-bottom string))))) + ;;; Common utility functions and macros @@ -699,9 +708,12 @@ (defun slime-process-available-input () "Process all complete messages that have arrived from Lisp." (with-current-buffer (process-buffer slime-net-process) - (while (slime-net-have-input-p) - (save-current-buffer - (slime-dispatch-event (slime-net-read) nil))))) + (unwind-protect + (while (slime-net-have-input-p) + (save-current-buffer + (slime-dispatch-event (slime-net-read)))) + (when (slime-net-have-input-p) + (run-at-time 0 nil 'slime-process-available-input))))) (defun slime-net-have-input-p () "Return true if a complete message is available." @@ -781,19 +793,17 @@ (defvar slime-state-name "[??]" "The name of the current state, for display in the modeline.") -(defun slime-push-state (state process-input) +(defun slime-push-state (state) "Push into a new state, saving the current state on the stack. -This may be called by a state machine to cause a state change. -If PROCESS-INPUT is non-nil the available input is processed." +This may be called by a state machine to cause a state change." (push state slime-state-stack) - (slime-activate-state process-input)) + (slime-activate-state)) -(defun slime-pop-state (process-input) +(defun slime-pop-state () "Pop back to the previous state from the stack. -This may be called by a state machine to finish its current state. -If PROCESS-INPUT is non-nil the available input is processed." +This may be called by a state machine to finish its current state." (pop slime-state-stack) - (slime-activate-state process-input)) + (slime-activate-state)) (defun slime-current-state () "The current state." @@ -804,11 +814,10 @@ (setq sldb-level 0) (setq slime-state-stack (list (slime-idle-state)))) -(defun slime-activate-state (process-input) +(defun slime-activate-state () "Activate the current state. This delivers an (activate) event to the state function, and updates -the state name for the modeline. -If PROCESS-INPUT is non-nil the available input is processed." +the state name for the modeline." (let ((state (slime-current-state))) (setq slime-state-name (ecase (slime-state-name state) @@ -817,18 +826,14 @@ (slime-debugging-state "[debug]") (slime-read-input-state "[read]"))) (force-mode-line-update) - (slime-dispatch-event '(activate) process-input))) + (slime-dispatch-event '(activate)))) -(defun slime-dispatch-event (event process-input) +(defun slime-dispatch-event (event) "Dispatch an event to the current state. Certain \"out of band\" events are handled specially instead of going -into the state machine. -If PROCESS-INPUT is non-nil the available input is processed." - (unwind-protect - (or (slime-handle-oob event) - (funcall (slime-state-function (slime-current-state)) event)) - (when process-input - (slime-process-available-input)))) +into the state machine." + (or (slime-handle-oob event) + (funcall (slime-state-function (slime-current-state)) event))) (defun slime-handle-oob (event) "Handle out-of-band events. @@ -939,7 +944,7 @@ (assert (= sldb-level 0))) ((:emacs-evaluate form-string package-name continuation) (slime-output-evaluate-request form-string package-name) - (slime-push-state (slime-evaluating-state continuation) t))) + (slime-push-state (slime-evaluating-state continuation)))) (defvar slime-evaluating-state-activation-hook nil "Hook called when the evaluating state is actived.") @@ -951,7 +956,7 @@ ((activate) (run-hooks 'slime-evaluating-state-activation-hook)) ((:ok result) - (slime-pop-state nil) + (slime-pop-state) (destructure-case continuation ((:function f) (funcall f result)) @@ -962,15 +967,14 @@ (destructure-case continuation ((:function f) (message "Evaluation aborted.") - (slime-pop-state t)) + (slime-pop-state)) ((:catch-tag tag) - (slime-pop-state nil) + (slime-pop-state) (when (member tag slime-stack-eval-tags) (throw tag `(:aborted)))))) ((:debug level condition restarts stack-depth frames) (slime-push-state - (slime-debugging-state level condition restarts stack-depth frames) - t)) + (slime-debugging-state level condition restarts stack-depth frames))) ((:emacs-interrupt) (slime-send-sigint)) ((:emacs-quit) @@ -978,7 +982,7 @@ ;; Instead, just cancel the continuation. (setq continuation (lambda (value) t))) ((:read-input requested tag) - (slime-push-state (slime-read-input-state requested tag) t))) + (slime-push-state (slime-read-input-state requested tag)))) (slime-defstate slime-debugging-state (level condition restarts depth frames) "Debugging state. @@ -992,24 +996,22 @@ (/= sldb-level-in-buffer level))) (sldb-setup condition restarts depth frames)))) ((:debug-return level) - (unwind-protect - (progn - (assert (= level sldb-level)) - ;; We must decrement here so we will notice when we are - ;; activated again, especially when we continue from the - ;; debugger and are activated a second time without entering - ;; a lower break level. - (decf sldb-level) - (when (= level 1) - (let ((sldb-buffer (get-buffer "*sldb*"))) - (when sldb-buffer - (delete-windows-on sldb-buffer) - (kill-buffer sldb-buffer))))) - (slime-pop-state t))) + (assert (= level sldb-level)) + ;; We must decrement here so we will notice when we are + ;; activated again, especially when we continue from the + ;; debugger and are activated a second time without entering + ;; a lower break level. + (decf sldb-level) + (when (= level 1) + (let ((sldb-buffer (get-buffer "*sldb*"))) + (when sldb-buffer + (delete-windows-on sldb-buffer) + (kill-buffer sldb-buffer)))) + (slime-pop-state)) ((:emacs-evaluate form-string package-name continuation) ;; recursive evaluation request (slime-output-evaluate-request form-string package-name) - (slime-push-state (slime-evaluating-state continuation) t))) + (slime-push-state (slime-evaluating-state continuation)))) (slime-defstate slime-read-input-state (request tag) "Reading state. @@ -1021,7 +1023,7 @@ (slime-show-output-buffer) (setq input (ignore-errors (read-string "<= ")))) (slime-net-send `(swank:take-input ,tag ,(concat input "\n"))) - (slime-pop-state t)))) + (slime-pop-state)))) ;;;;; Utilities @@ -1042,8 +1044,7 @@ (defun slime-eval-string-async (string package continuation) (when (slime-busy-p) (error "Lisp is already busy evaluating a request.")) - (slime-dispatch-event `(:emacs-evaluate ,string ,package ,continuation) - t)) + (slime-dispatch-event `(:emacs-evaluate ,string ,package ,continuation))) (defconst +slime-sigint+ 2) @@ -2283,11 +2284,11 @@ (defun slime-interrupt () (interactive) - (slime-dispatch-event '(:emacs-interrupt) t)) + (slime-dispatch-event '(:emacs-interrupt))) (defun slime-quit () (interactive) - (slime-dispatch-event '(:emacs-quit) t)) + (slime-dispatch-event '(:emacs-quit))) (defun slime-set-package (package) (interactive (list (slime-read-package-name "Package: " @@ -2672,10 +2673,13 @@ ("a" 'sldb-abort) ("r" 'sldb-invoke-restart) ("q" 'sldb-quit) - - ("\M-." 'slime-edit-fdefinition) - ("\M-," 'slime-pop-find-definition-stack) - ) + (":" 'slime-interactive-eval)) + +(dolist (spec slime-keys) + (destructuring-bind (key command &key sldb prefixed &allow-other-keys) spec + (when sldb + (let ((key (if prefixed (concat slime-prefix-key key) key))) + (define-key sldb-mode-map key command))))) ;; Keys 0-9 are shortcuts to invoke particular restarts. (defmacro define-sldb-invoke-restart-key (number key) @@ -3094,39 +3098,12 @@ "True if STATES describes the current stack of states." (equal states (mapcar #'slime-state-name slime-state-stack))) -(defun slime-time< (time1 time2) - "Compare two encoded time values." - (multiple-value-bind (high1 low1 micros1) time1 - (multiple-value-bind (high2 low2 micros2) time2 - (or (< high1 high2) - (and (= high1 high2) - (or (< low1 low2) - (and (= low1 low2) - (if (and micros1 micros2) - (< micros1 micros2) - micros2)))))))) - -(defun* slime-time-add (time &key (second 0) (minute 0) (hour 0) - (day 0) (month 0) (year 0)) - "Add the specified time to the encoded time value TIME." - (multiple-value-bind (old-second old-minute old-hour - old-day old-month old-year - old-dow old-dst old-zone) - (decode-time time) - (encode-time (+ old-second second) - (+ old-minute minute) - (+ old-hour hour) - (+ old-day day) - (+ old-month month) - (+ old-year year) - old-zone))) - (defun slime-sync-state-stack (state-stack timeout) "Wait until the machine's stack is STATE-STACK or the timeout \ -expires.\nThe timeout is given in seconds." - (let ((end (slime-time-add (current-time) :second timeout))) +expires.\nThe timeout is given in seconds (a floating point number)." + (let ((end (time-add (current-time) (seconds-to-time timeout)))) (loop until (or (slime-test-state-stack state-stack) - (slime-time< end (current-time))) + (time-less-p end (current-time))) do (accept-process-output nil 0 100000)))) (def-slime-test loop-interrupt-quit () @@ -3319,7 +3296,47 @@ (1- (max beg end)) (max beg end))) (goto-char (point-min)) + ;; XXX make this xemacs compatible (1+ (vertical-motion (buffer-size) window)))))) + +(defun-if-undefined seconds-to-time (seconds) + "Convert SECONDS (a floating point number) to a time value." + (list (floor seconds 65536) + (floor (mod seconds 65536)) + (floor (* (- seconds (ffloor seconds)) 1000000)))) + +(defun-if-undefined time-less-p (t1 t2) + "Say whether time value T1 is less than time value T2." + (or (< (car t1) (car t2)) + (and (= (car t1) (car t2)) + (< (nth 1 t1) (nth 1 t2))))) + +(defun-if-undefined time-add (t1 t2) + "Add two time values. One should represent a time difference." + (let ((high (car t1)) + (low (if (consp (cdr t1)) (nth 1 t1) (cdr t1))) + (micro (if (numberp (car-safe (cdr-safe (cdr t1)))) + (nth 2 t1) + 0)) + (high2 (car t2)) + (low2 (if (consp (cdr t2)) (nth 1 t2) (cdr t2))) + (micro2 (if (numberp (car-safe (cdr-safe (cdr t2)))) + (nth 2 t2) + 0))) + ;; Add + (setq micro (+ micro micro2)) + (setq low (+ low low2)) + (setq high (+ high high2)) + + ;; Normalize + ;; `/' rounds towards zero while `mod' returns a positive number, + ;; so we can't rely on (= a (+ (* 100 (/ a 100)) (mod a 100))). + (setq low (+ low (/ micro 1000000) (if (< micro 0) -1 0))) + (setq micro (mod micro 1000000)) + (setq high (+ high (/ low 65536) (if (< low 0) -1 0))) + (setq low (logand low 65535)) + + (list high low micro))) (defun emacs-20-p () (and (not (featurep 'xemacs)) From heller at common-lisp.net Wed Oct 22 21:04:55 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 22 Oct 2003 17:04:55 -0400 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14246 Modified Files: swank.lisp Log Message: (read-next-form, send-to-emacs): Assume *emacs-io* is a character stream. Add the necessary char-code/code-char conversions. Date: Wed Oct 22 17:04:55 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.43 slime/swank.lisp:1.44 --- slime/swank.lisp:1.43 Tue Oct 21 06:59:04 2003 +++ slime/swank.lisp Wed Oct 22 17:04:55 2003 @@ -70,15 +70,16 @@ S-expression to be evaluated to handle the request. If an error occurs during parsing, it will be noted and control will be tranferred back to the main request handling loop." - (handler-case - (let* ((length (logior (ash (read-byte *emacs-io*) 16) - (ash (read-byte *emacs-io*) 8) - (read-byte *emacs-io*))) - (string (make-string length))) - (read-sequence string *emacs-io*) - (read-form string)) - (condition (c) - (throw 'serve-request-catcher c)))) + (flet ((next-byte () (char-code (read-char *emacs-io*)))) + (handler-case + (let* ((length (logior (ash (next-byte) 16) + (ash (next-byte) 8) + (next-byte))) + (string (make-string length))) + (read-sequence string *emacs-io*) + (read-form string)) + (condition (c) + (throw 'serve-request-catcher c))))) (defun read-form (string) (with-standard-io-syntax @@ -90,7 +91,8 @@ (let* ((string (prin1-to-string-for-emacs object)) (length (1+ (length string)))) (loop for position from 16 downto 0 by 8 - do (write-byte (ldb (byte 8 position) length) *emacs-io*)) + do (write-char (code-char (ldb (byte 8 position) length)) + *emacs-io*)) (write-string string *emacs-io*) (terpri *emacs-io*) (force-output *emacs-io*))) From heller at common-lisp.net Wed Oct 22 21:06:05 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 22 Oct 2003 17:06:05 -0400 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14802 Modified Files: swank-cmucl.lisp Log Message: (setup-request-handler): Create a character stream. (read-next-form): Removed. Date: Wed Oct 22 17:06:04 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.10 slime/swank-cmucl.lisp:1.11 --- slime/swank-cmucl.lisp:1.10 Mon Oct 20 11:09:10 2003 +++ slime/swank-cmucl.lisp Wed Oct 22 17:06:01 2003 @@ -87,7 +87,7 @@ "Setup request handling for SOCKET." (let* ((stream (sys:make-fd-stream socket :input t :output t - :element-type 'unsigned-byte)) + :element-type 'base-char)) (input (make-slime-input-stream)) (output (make-slime-output-stream)) (io (make-two-way-stream input output))) @@ -109,17 +109,6 @@ "~&;; Connection to Emacs lost.~%;; [~A]~%" condition)) (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*)) (close *emacs-io*))))) - -(defun read-next-form () - (handler-case - (let* ((length (logior (ash (read-byte *emacs-io*) 16) - (ash (read-byte *emacs-io*) 8) - (read-byte *emacs-io*))) - (string (make-string length))) - (sys:read-n-bytes *emacs-io* string 0 length) - (read-form string)) - (condition (c) - (throw 'serve-request-catcher c)))) ;;; From heller at common-lisp.net Wed Oct 22 21:09:39 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 22 Oct 2003 17:09:39 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17036 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Oct 22 17:09:38 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.60 slime/ChangeLog:1.61 --- slime/ChangeLog:1.60 Wed Oct 22 15:05:58 2003 +++ slime/ChangeLog Wed Oct 22 17:09:38 2003 @@ -1,3 +1,37 @@ +2003-10-22 Helmut Eller + + * swank-cmucl.lisp (setup-request-handler): Create a character + stream. + (read-next-form): Removed. + + * swank.lisp (read-next-form, send-to-emacs): Assume *emacs-io* is + a character stream. Add the necessary char-code/code-char + conversions. + + * slime.el: slime-keys: Add :sldb keywords for keys useful in the + debugger. + (slime-init-keymaps): Allow allow :sldb keywords. + + inferior-lisp-mode-hook: Display the inf-lisp buffer if there is + some output. + + (slime-process-available-input): Start a timer to process any + remaining input. + (slime-dispatch-event): The timer should take care of any lost + input. So don't process the available input here. Remove the + process-input argument. + (slime-push-state, slime-pop-state, slime-activate-state, + slime-idle-state, slime-evaluating-state): Update callers. + (slime-debugging-state): Remove the unwind-protect in the + :debug-return clause. Should not be necessary. + + sldb-mode-map: Define more slime-mode keys. + + (slime-time<, slime-time-add): Removed. Emacs-21 has equivalent time + functions. + (slime-sync-state-stack): Use Emacs-21 time-date functions. + (seconds-to-time, time-less-p, time-add): Compatibility defuns. + 2003-10-22 Luke Gorrie * slime.el (slime): With a prefix argument, prompt for the port From lgorrie at common-lisp.net Thu Oct 23 15:52:28 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 23 Oct 2003 11:52:28 -0400 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4618 Modified Files: swank-sbcl.lisp Log Message: (accept-connection): Use a character stream to match swank.lisp. Date: Thu Oct 23 11:52:26 2003 Author: lgorrie Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.12 slime/swank-sbcl.lisp:1.13 --- slime/swank-sbcl.lisp:1.12 Tue Oct 21 15:36:23 2003 +++ slime/swank-sbcl.lisp Thu Oct 23 11:52:24 2003 @@ -67,7 +67,7 @@ "Accept a SWANK TCP connection on SOCKET." (let* ((socket (sb-bsd-sockets:socket-accept server-socket)) (stream (sb-bsd-sockets:socket-make-stream - socket :input t :output t :element-type 'unsigned-byte))) + socket :input t :output t :element-type 'base-char))) (sb-sys:add-fd-handler (sb-bsd-sockets:socket-file-descriptor socket) :input (lambda (fd) From lgorrie at common-lisp.net Thu Oct 23 15:55:08 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 23 Oct 2003 11:55:08 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7067 Modified Files: ChangeLog Log Message: Date: Thu Oct 23 11:55:08 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.61 slime/ChangeLog:1.62 --- slime/ChangeLog:1.61 Wed Oct 22 17:09:38 2003 +++ slime/ChangeLog Thu Oct 23 11:55:07 2003 @@ -1,3 +1,8 @@ +2003-10-23 Luke Gorrie + + * swank-sbcl.lisp (accept-connection): Use a character stream to + match swank.lisp. + 2003-10-22 Helmut Eller * swank-cmucl.lisp (setup-request-handler): Create a character From lgorrie at common-lisp.net Thu Oct 23 16:24:59 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 23 Oct 2003 12:24:59 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26439 Modified Files: slime.el Log Message: (slime-maybe-start-lisp): Restart inferior-lisp if the process has died. Date: Thu Oct 23 12:24:59 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.55 slime/slime.el:1.56 --- slime/slime.el:1.55 Wed Oct 22 17:03:24 2003 +++ slime/slime.el Thu Oct 23 12:24:59 2003 @@ -565,7 +565,7 @@ (defun slime-maybe-start-lisp () "Start an inferior lisp unless one is already running." - (unless (get-buffer "*inferior-lisp*") + (unless (get-buffer-process (get-buffer "*inferior-lisp*")) (call-interactively 'inferior-lisp) (slime-start-swank-server))) From lgorrie at common-lisp.net Thu Oct 23 16:25:33 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 23 Oct 2003 12:25:33 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv27006 Modified Files: ChangeLog Log Message: Date: Thu Oct 23 12:25:32 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.62 slime/ChangeLog:1.63 --- slime/ChangeLog:1.62 Thu Oct 23 11:55:07 2003 +++ slime/ChangeLog Thu Oct 23 12:25:32 2003 @@ -1,5 +1,8 @@ 2003-10-23 Luke Gorrie + * slime.el (slime-maybe-start-lisp): Restart inferior-lisp if the + process has died. + * swank-sbcl.lisp (accept-connection): Use a character stream to match swank.lisp. From lgorrie at common-lisp.net Fri Oct 24 21:11:40 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 24 Oct 2003 17:11:40 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv1674 Modified Files: slime.el Log Message: (inferior-slime-return): Command bound to RET in inferior-slime-mode: only send the current input to Lisp if it is a complete expression (or prefix argument is given). Two reasons: it makes the input history contain complete expressions, and it lets us nicely indent multiple-line inputs. (Thanks Raymond Toy for the suggestions.) Date: Fri Oct 24 17:11:40 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.56 slime/slime.el:1.57 --- slime/slime.el:1.56 Thu Oct 23 12:24:59 2003 +++ slime/slime.el Fri Oct 24 17:11:39 2003 @@ -225,6 +225,28 @@ ((slime-buffer-package (":" slime-buffer-package) "") slime-state-name)))) +(defun inferior-slime-return () + "Handle the return key in the inferior-lisp buffer. +The current input should only be sent if a whole expression has been +entered, i.e. the parenthesis are matched. + +A prefix argument disables this behaviour." + (interactive) + (if (or current-prefix-arg (inferior-slime-input-complete-p)) + (comint-send-input) + (insert "\n") + (lisp-indent-line))) + +(defun inferior-slime-input-complete-p () + "Return true if the input is complete in the inferior lisp buffer." + (ignore-errors + (save-excursion + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (while (not (eobp)) + (skip-chars-forward " \t\r\n") + (unless (eobp) (slime-forward-sexp))) + t))) + ;;;;; Key bindings @@ -288,7 +310,9 @@ (setq key (concat slime-prefix-key key))) (define-key slime-mode-map key command) (when inferior - (define-key inferior-slime-mode-map key command))) + (define-key inferior-slime-mode-map key command)) + ;; Extras.. + (define-key inferior-slime-mode-map [return] 'inferior-slime-return)) (defun slime-init-keymaps () "(Re)initialize the keymaps for `slime-mode' and `inferior-slime-mode'." From lgorrie at common-lisp.net Fri Oct 24 21:12:08 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 24 Oct 2003 17:12:08 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv1885 Modified Files: ChangeLog Log Message: Date: Fri Oct 24 17:12:07 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.63 slime/ChangeLog:1.64 --- slime/ChangeLog:1.63 Thu Oct 23 12:25:32 2003 +++ slime/ChangeLog Fri Oct 24 17:12:07 2003 @@ -1,3 +1,12 @@ +2003-10-24 Luke Gorrie + + * slime.el (inferior-slime-return): Command bound to RET in + inferior-slime-mode: only send the current input to Lisp if it is + a complete expression (or prefix argument is given). Two reasons: + it makes the input history contain complete expressions, and it + lets us nicely indent multiple-line inputs. (Thanks Raymond Toy + for the suggestions.) + 2003-10-23 Luke Gorrie * slime.el (slime-maybe-start-lisp): Restart inferior-lisp if the From lgorrie at common-lisp.net Fri Oct 24 22:19:23 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 24 Oct 2003 18:19:23 -0400 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5251 Modified Files: slime.el Log Message: (inferior-slime-closing-return): New command that closes all open lists and sends the result to Lisp. Bound to C-RET and (for people who use C-m for RET) C-M-m. (inferior-slime-indent-line): Improved indentation in the inferior list buffer. Date: Fri Oct 24 18:19:22 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.57 slime/slime.el:1.58 --- slime/slime.el:1.57 Fri Oct 24 17:11:39 2003 +++ slime/slime.el Fri Oct 24 18:19:20 2003 @@ -235,6 +235,19 @@ (if (or current-prefix-arg (inferior-slime-input-complete-p)) (comint-send-input) (insert "\n") + (inferior-slime-indent-line))) + +(defun inferior-slime-indent-line () + "Indent the current line, ignoring everything before the prompt." + (interactive) + (save-restriction + (let ((indent-start + (save-excursion + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (let ((inhibit-field-text-motion t)) + (beginning-of-line 1)) + (point)))) + (narrow-to-region indent-start (point-max))) (lisp-indent-line))) (defun inferior-slime-input-complete-p () @@ -242,11 +255,26 @@ (ignore-errors (save-excursion (goto-char (process-mark (get-buffer-process (current-buffer)))) - (while (not (eobp)) - (skip-chars-forward " \t\r\n") - (unless (eobp) (slime-forward-sexp))) + ;; Keep stepping over blanks and sexps until the end of buffer + ;; is reached or an error occurs + (loop do (or (skip-chars-forward " \t\r\n") + (looking-at ")")) ; tollerate extra close parens + until (eobp) + do (slime-forward-sexp)) t))) +(defun inferior-slime-closing-return () + "Send the current expression to Lisp after closing any open lists." + (interactive) + (goto-char (point-max)) + (save-restriction + (narrow-to-region (process-mark (get-buffer-process (current-buffer))) + (point-max)) + (while (ignore-errors (save-excursion (backward-up-list 1) t)) + (insert ")"))) + (comint-send-input)) + + ;;;;; Key bindings @@ -310,15 +338,19 @@ (setq key (concat slime-prefix-key key))) (define-key slime-mode-map key command) (when inferior - (define-key inferior-slime-mode-map key command)) - ;; Extras.. - (define-key inferior-slime-mode-map [return] 'inferior-slime-return)) + (define-key inferior-slime-mode-map key command))) (defun slime-init-keymaps () "(Re)initialize the keymaps for `slime-mode' and `inferior-slime-mode'." (interactive) (loop for (key command . keys) in slime-keys - do (apply #'slime-define-key key command :allow-other-keys t keys))) + do (apply #'slime-define-key key command :allow-other-keys t keys)) + ;; Extras.. + (define-key inferior-slime-mode-map [return] 'inferior-slime-return) + (define-key inferior-slime-mode-map + [(control return)] 'inferior-slime-closing-return) + (define-key inferior-slime-mode-map + [(meta control ?m)] 'inferior-slime-closing-return)) (slime-init-keymaps) From lgorrie at common-lisp.net Fri Oct 24 22:20:46 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 24 Oct 2003 18:20:46 -0400 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6084 Modified Files: ChangeLog Log Message: Date: Fri Oct 24 18:20:46 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.64 slime/ChangeLog:1.65 --- slime/ChangeLog:1.64 Fri Oct 24 17:12:07 2003 +++ slime/ChangeLog Fri Oct 24 18:20:46 2003 @@ -1,3 +1,11 @@ +2003-10-25 Luke Gorrie + + * slime.el (inferior-slime-closing-return): New command that + closes all open lists and sends the result to Lisp. Bound to C-RET + and (for people who use C-m for RET) C-M-m. + (inferior-slime-indent-line): Improved indentation in the inferior + list buffer. + 2003-10-24 Luke Gorrie * slime.el (inferior-slime-return): Command bound to RET in From lgorrie at common-lisp.net Sat Oct 25 01:54:02 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 24 Oct 2003 21:54:02 -0400 Subject: [slime-cvs] CVS update: slime/swank.lisp slime/swank-sbcl.lisp slime/swank-openmcl.lisp slime/swank-cmucl.lisp slime/slime.el slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10599 Modified Files: swank.lisp swank-sbcl.lisp swank-openmcl.lisp swank-cmucl.lisp slime.el ChangeLog Log Message: Changed the connection setup to use a dynamic collision-free TCP port. The new protocol is this: Emacs calls (swank:start-server FILENAME) via the listener. FILENAME is /tmp/slime.${emacspid} Lisp starts a TCP server on a dynamic available port and writes the port number it gets to FILENAME. Emacs asynchronously polls for FILENAME's creation. When it exists, Emacs reads the port number, deletes the file, and makes the connection. The advantage is that you can run multiple Emacsen each with an inferior lisp, and the port numbers will never collide and Emacs will always connect to the right lisp. All backends are updated, but only CMUCL and SBCL are tested. Therefore, OpenMCL is almost certainly broken just now. Date: Fri Oct 24 21:54:01 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.44 slime/swank.lisp:1.45 --- slime/swank.lisp:1.44 Wed Oct 22 17:04:55 2003 +++ slime/swank.lisp Fri Oct 24 21:54:00 2003 @@ -30,9 +30,15 @@ ;;; Setup and Hooks -(defun start-server (&optional (port server-port)) - "Start the Slime backend on TCP port `port'." - (create-swank-server port :reuse-address t) +(defun start-server (port-file-namestring) + "Create a SWANK server and write its port number to the file +PORT-FILE-NAMESTRING in ascii text." + (let ((port (create-swank-server 0 :reuse-address t))) + (with-open-file (s port-file-namestring + :direction :output + :if-exists :overwrite + :if-does-not-exist :create) + (format s "~S~%" port))) (when *swank-debug-p* (format *debug-io* "~&;; Swank ready.~%"))) Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.13 slime/swank-sbcl.lisp:1.14 --- slime/swank-sbcl.lisp:1.13 Thu Oct 23 11:52:24 2003 +++ slime/swank-sbcl.lisp Fri Oct 24 21:54:00 2003 @@ -61,13 +61,17 @@ (sb-bsd-sockets:socket-file-descriptor socket) :input (lambda (fd) (declare (ignore fd)) - (accept-connection socket))))) + (accept-connection socket))) + (nth-value 1 (sb-bsd-sockets:socket-name socket)))) (defun accept-connection (server-socket) - "Accept a SWANK TCP connection on SOCKET." + "Accept one Swank TCP connection on SOCKET and then close it." (let* ((socket (sb-bsd-sockets:socket-accept server-socket)) (stream (sb-bsd-sockets:socket-make-stream socket :input t :output t :element-type 'base-char))) + (sb-sys:invalidate-descriptor (sb-bsd-sockets:socket-file-descriptor + server-socket)) + (sb-bsd-sockets:socket-close server-socket) (sb-sys:add-fd-handler (sb-bsd-sockets:socket-file-descriptor socket) :input (lambda (fd) Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.11 slime/swank-openmcl.lisp:1.12 --- slime/swank-openmcl.lisp:1.11 Sun Oct 19 17:40:29 2003 +++ slime/swank-openmcl.lisp Fri Oct 24 21:54:00 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.11 2003/10/19 21:40:29 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.12 2003/10/25 01:54:00 lgorrie Exp $ ;;; ;;; @@ -59,20 +59,24 @@ ;; blocks on its TCP port while waiting for forms to evaluate. (defun create-swank-server (port &key reuse-address) - "Create a Swank TCP server on `port'." - (ccl:process-run-function "Swank Request Processor" #'swank-main-loop - port reuse-address)) - -(defun swank-main-loop (port reuse-address) - "Create the TCP server and accept connections in a new thread." + "Create a Swank TCP server on `port'. +Return the port number that the socket is actually listening on." (let ((server-socket (ccl:make-socket :connect :passive :local-port port :reuse-address reuse-address))) - (loop - (let ((socket (ccl:accept-connection server-socket :wait t))) - (ccl:process-run-function - (list :name (format nil "Swank Client ~D" (ccl:socket-os-fd socket)) - :initial-bindings `((*emacs-io* . ',socket))) - #'request-loop))))) + (ccl:process-run-function "Swank Request Processor" + #'swank-accept-connection + server-socket) + (ccl:local-port server-socket))) + +(defun swank-accept-connection (server-socket) + "Accept one Swank TCP connection on SOCKET and then close it. +Run the connection handler in a new thread." + (let ((socket (ccl:accept-connection server-socket :wait t))) + (close server-socket) + (ccl:process-run-function + (list :name (format nil "Swank Client ~D" (ccl:socket-os-fd socket)) + :initial-bindings `((*emacs-io* . ',socket))) + #'request-loop))) (defun request-loop () "Thread function for a single Swank connection. Processes requests Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.11 slime/swank-cmucl.lisp:1.12 --- slime/swank-cmucl.lisp:1.11 Wed Oct 22 17:06:01 2003 +++ slime/swank-cmucl.lisp Fri Oct 24 21:54:00 2003 @@ -73,15 +73,17 @@ (let* ((hostent (ext:lookup-host-entry address)) (address (car (ext:host-entry-addr-list hostent))) (ip (ext:htonl address))) - (system:add-fd-handler - (ext:create-inet-listener port :stream - :reuse-address reuse-address - :host ip) - :input #'accept-connection))) + (let ((fd (ext:create-inet-listener port :stream + :reuse-address reuse-address + :host ip))) + (system:add-fd-handler fd :input #'accept-connection) + (nth-value 1 (ext::get-socket-host-and-port fd))))) (defun accept-connection (socket) - "Accept a SWANK TCP connection on SOCKET." - (setup-request-handler (ext:accept-tcp-connection socket))) + "Accept one Swank TCP connection on SOCKET and then close it." + (setup-request-handler (ext:accept-tcp-connection socket)) + (sys:invalidate-descriptor socket) + (unix:unix-close socket)) (defun setup-request-handler (socket) "Setup request handling for SOCKET." Index: slime/slime.el diff -u slime/slime.el:1.58 slime/slime.el:1.59 --- slime/slime.el:1.58 Fri Oct 24 18:19:20 2003 +++ slime/slime.el Fri Oct 24 21:54:00 2003 @@ -61,9 +61,6 @@ (require 'easy-mmode) (defalias 'define-minor-mode 'easy-mmode-define-minor-mode)) -(defvar slime-swank-port 4005 - "TCP port number for the Lisp Swank server.") - (defvar slime-path (let ((path (locate-library "slime"))) (and path (file-name-directory path))) @@ -599,50 +596,45 @@ "Timer object for connection retries.") (defun slime () - "Start an inferior^_superior Lisp and connect to its Swank server. -With a prefix argument, prompt for the port number for Lisp -communication. The port is remembered for future connections." + "Start an inferior^_superior Lisp and connect to its Swank server." (interactive) - (when current-prefix-arg - (slime-read-and-update-swank-port)) (when (slime-connected-p) (slime-disconnect)) (slime-maybe-start-lisp) - (slime-connect "localhost" slime-swank-port)) + (slime-connect)) -(defun slime-read-and-update-swank-port () - "Prompt the user for the port number to use for Lisp communication." - (let* ((port-string (format "%S" slime-swank-port)) - (new-port-string (read-from-minibuffer "SLIME Port: " port-string)) - (new-port (read new-port-string))) - (if (integerp new-port) - (setq slime-swank-port new-port) - (error "Not a valid port: %S" new-port-string)))) - (defun slime-maybe-start-lisp () "Start an inferior lisp unless one is already running." (unless (get-buffer-process (get-buffer "*inferior-lisp*")) (call-interactively 'inferior-lisp) - (slime-start-swank-server))) + (comint-proc-query (inferior-lisp-proc) + (format "(load %S)\n" + (concat slime-path slime-backend))))) (defun slime-start-swank-server () "Start a Swank server on the inferior lisp." (comint-proc-query (inferior-lisp-proc) - (format "(load %S)\n" - (concat slime-path slime-backend))) - (comint-proc-query (inferior-lisp-proc) - (format "(swank:start-server %S)\n" slime-swank-port))) + (format "(swank:start-server %S)\n" + (slime-swank-port-file)))) + +(defun slime-swank-port-file () + "Filename where the SWANK server writes its TCP port number." + (format "/tmp/slime.%S" (emacs-pid))) + +(defun slime-read-swank-port () + "Read the Swank server port number from the `slime-swank-port-file'." + (save-excursion + (with-temp-buffer + (insert-file-contents (slime-swank-port-file)) + (goto-char (point-min)) + (let ((port (read (current-buffer)))) + (assert (integerp port)) + port)))) -(defun slime-connect (host port &optional retries) +(defun slime-connect (&optional retries) "Connect to a running Swank server." - (interactive (list (read-string "Host: " "localhost") - (let ((port - (read-string "Port: " - (number-to-string slime-swank-port)))) - (or (ignore-errors (string-to-number port)) port)))) - (lexical-let ((host host) - (port port) - (retries (or retries slime-swank-connection-retries)) + (slime-start-swank-server) + (lexical-let ((retries (or retries slime-swank-connection-retries)) (attempt 0)) (labels ;; A small one-state machine to attempt a connection with @@ -651,15 +643,19 @@ () (unless (active-minibuffer-window) (message "\ -Connecting to Swank at %s:%S. (Abort with `M-x slime-disconnect'.)" - host port)) - (setq slime-state-name (format "[connect:%S]" (incf attempt))) +Polling %S.. (Abort with `M-x slime-disconnect'.)" + (slime-swank-port-file))) + (setq slime-state-name (format "[polling:%S]" (incf attempt))) (force-mode-line-update) (setq slime-connect-retry-timer nil) ; remove old timer - (cond ((slime-net-connect host port) - (slime-init-connection) - (message "Connected to Swank on %s:%S. %s" - host port (slime-random-words-of-encouragement))) + (cond ((file-exists-p (slime-swank-port-file)) + (let ((port (slime-read-swank-port))) + (message "Connecting to Swank on port %S.." port) + (delete-file (slime-swank-port-file)) + (slime-net-connect "localhost" port) + (slime-init-connection) + (message "Connected to Swank server on port %S. %s" + port (slime-random-words-of-encouragement)))) ((and retries (zerop retries)) (message "Failed to connect to Swank.")) (t @@ -711,20 +707,16 @@ (defun slime-net-connect (host port) "Establish a connection with a CL." - (condition-case nil - (progn - (setq slime-net-process - (open-network-stream "SLIME Lisp" nil host port)) - (let ((buffer (slime-make-net-buffer "*cl-connection*"))) - (set-process-buffer slime-net-process buffer) - (set-process-filter slime-net-process 'slime-net-filter) - (set-process-sentinel slime-net-process 'slime-net-sentinel) - (when (fboundp 'set-process-coding-system) - (set-process-coding-system slime-net-process - 'no-conversion 'no-conversion))) - slime-net-process) - (file-error () nil) - (network-error () nil))) + (setq slime-net-process + (open-network-stream "SLIME Lisp" nil host port)) + (let ((buffer (slime-make-net-buffer "*cl-connection*"))) + (set-process-buffer slime-net-process buffer) + (set-process-filter slime-net-process 'slime-net-filter) + (set-process-sentinel slime-net-process 'slime-net-sentinel) + (when (fboundp 'set-process-coding-system) + (set-process-coding-system slime-net-process + 'no-conversion 'no-conversion))) + slime-net-process) (defun slime-make-net-buffer (name) "Make a buffer suitable for a network process." Index: slime/ChangeLog diff -u slime/ChangeLog:1.65 slime/ChangeLog:1.66 --- slime/ChangeLog:1.65 Fri Oct 24 18:20:46 2003 +++ slime/ChangeLog Fri Oct 24 21:54:00 2003 @@ -1,5 +1,23 @@ 2003-10-25 Luke Gorrie + * Everywhere: Changed the connection setup to use a dynamic + collision-free TCP port. The new protocol is this: + + Emacs calls (swank:start-server FILENAME) via the + listener. FILENAME is /tmp/slime.${emacspid} + Lisp starts a TCP server on a dynamic available port and writes + the port number it gets to FILENAME. + Emacs asynchronously polls for FILENAME's creation. When it + exists, Emacs reads the port number, deletes the file, and makes + the connection. + + The advantage is that you can run multiple Emacsen each with an + inferior lisp, and the port numbers will never collide and Emacs + will always connect to the right lisp. + + All backends are updated, but only CMUCL and SBCL are + tested. Therefore, OpenMCL is almost certainly broken just now. + * slime.el (inferior-slime-closing-return): New command that closes all open lists and sends the result to Lisp. Bound to C-RET and (for people who use C-m for RET) C-M-m. From lgorrie at common-lisp.net Mon Oct 27 04:04:56 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 26 Oct 2003 23:04:56 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp slime/swank-cmucl.lisp slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5112 Modified Files: Tag: backhackattack-1 swank.lisp swank-cmucl.lisp slime.el Log Message: (on bighackattack-1 branch) Took a step towards refactoring the backends, working on just the CMUCL one to begin with. The backend is now split into a separate package, so that all necessary symbols are explicit. Major major hackage, but the test suite passes for CMUCL. Have not made any actual improvements yet - except for adding asynchronous evaluation, which I should have committed before the hackage that lead to the branch. "Won't stay branched for long!" Date: Sun Oct 26 23:04:56 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.45 slime/swank.lisp:1.45.2.1 --- slime/swank.lisp:1.45 Fri Oct 24 21:54:00 2003 +++ slime/swank.lisp Sun Oct 26 23:04:56 2003 @@ -1,6 +1,6 @@ -;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- -;;; -;;; swank.lisp --- the portable bits +;;;; -*- mode: lisp; mode: outline-minor; outline-regexp: ";;;;;*"; indent-tabs-mode: nil -*- + +;;;; swank.lisp --- the portable bits ;;; ;;; Created 2003, Daniel Barlow ;;; @@ -11,10 +11,64 @@ (defpackage :swank (:use :common-lisp) (:nicknames "SWANK-IMPL") - (:export #:start-server))) + (:export + + ;;-- Emacs entry-points + #:start-server + #:eval-string #:oneway-eval-string + #:interactive-eval #:interactive-eval-region + #:re-evaluate-defvar + #:pprint-eval + #:set-package + #:features + #:compiler-notes-for-file + #:compiler-notes-for-emacs + #:list-all-package-names + #:take-input + + ;;-- Callbacks for the backend to implement. + #:create-swank-server + #:call-trapping-compilation-notes + #:call-with-debugging-environment + #:swank-compile-file #:swank-compile-string + #:arglist-string + #:who-calls #:who-references #:who-binds + #:who-sets #:who-macroexpands + #:list-callers #:list-callees + #:function-source-location-for-emacs + #:frame-source-location-for-emacs + #:eval-string-in-frame + #:frame-locals #:frame-catch-tags + #:invoke-nth-restart #:sldb-continue #:sldb-abort + #:throw-to-toplevel + #:describe-setf-function #:describe-type #:describe-class + #:swank-macroexpand-all + #:toggle-trace-fdefinition + #:getpid + #:backtrace-for-emacs #:debugger-info-for-emacs + #:set-default-directory + #:init-inspector + #:inspect-nth-part + #:inspector-pop + #:inspector-next + #:quit-inspector + #:describe-inspectee + + ;;-- Library for backend to call + #:read-from-emacs #:send-to-emacs + #:*swank-debugger-condition* #:*sldb-level* #:*swank-debugger-hook* + #:*swank-debug-p* + + #:*buffer-package* #:*compiler-notes* #:*notes-database* #:*previous-compiler-condition* #:*previous-context* #:*sldb-level* #:*swank-debugger-condition* + #:apply-macro-expander #:backtrace-for-emacs #:call-with-compilation-hooks #:clear-note-database #:from-string #:print-description-to-string #:to-string + + #:*emacs-io* #:*slime-output* #:*slime-input* #:*slime-io* + ))) (in-package :swank) + +;;;; Global variables (defvar *swank-io-package* (let ((package (make-package "SWANK-IO-PACKAGE"))) (import '(nil t quote) package) @@ -28,12 +82,73 @@ (defvar *swank-debug-p* t "When true, print extra debugging information.") +(defparameter callbacks '() + "List of callback functions to be implemented by backends.") + +(defmacro defcallback (name arglist docstring) + `(defun ,name (&rest args) + ,docstring + (declare (ignore args)) + (format t "BAD CALLBACK: ~S" ',name))) + + +;;;; Callback functions for the backend. + +(defcallback create-swank-server (port &key reuse-address address) + "Create a Swank TCP server to accept a single connection. +Returns the port number the connection is actually listening on.") +(defcallback swank-compile-file (filename loadp) + "Compile FILENAME. If LOADP is non-nil, load it afterwards.") +(defcallback swank-compile-string (string buffer start) + "Compile STRING. +BUFFER and START indicate the position in Emacs that STRING comes from.") +(defcallback call-trapping-compilation-notes (function) + "Call FUNCTION, and record any resulting compilation notes.") +(defcallback arglist-string (function-name) + "Return a string describing FUNCTION-NAME's argument list.") +(defcallback who-calls (symbol) "") +(defcallback who-references (symbol) "") +(defcallback who-binds (symbol) "") +(defcallback who-sets (symbol) "") +(defcallback who-macroexpands (symbol) "") +(defcallback list-callers (symbol-name) "") ; FIXME: s/symbol-name/symbol/ +(defcallback list-callees (symbol-name) "") +(defcallback function-source-location-for-emacs (&rest _) "") +(defcallback frame-source-location-for-emacs (&rest _) "") +(defcallback eval-string-in-frame (&rest _) "") +(defcallback frame-locals (&rest _) "") +(defcallback frame-catch-tags (&rest _) "") +(defcallback invoke-nth-restart (&rest _) "") +(defcallback sldb-continue (&rest _) "") +(defcallback sldb-abort (&rest _) "") +(defcallback throw-to-toplevel (&rest _) "") +(defcallback describe-setf-function (&rest _) "") +(defcallback describe-type (&rest _) "") +(defcallback describe-class (&rest _) "") +(defcallback swank-macroexpand-all (&rest _) "") +(defcallback toggle-trace-fdefinition (&rest _) "") +(defcallback getpid (&rest _) "") +(defcallback backtrace-for-emacs (&rest _) "") +(defcallback debugger-info-for-emacs (&rest _) "") +(defcallback set-default-directory (&rest _) "") +(defcallback init-inspector (&rest _) "") +(defcallback inspector-pop (&rest _) "") +(defcallback inspector-next (&rest _) "") +(defcallback quit-inspector (&rest _) "") +(defcallback describe-inspectee (&rest _) "") + +;;; These variables are always bound when debugger callbacks are made. + +(defvar *swank-debugger-condition*) +(defvar *swank-debugger-hook*) +(defvar *sldb-level* 0) + ;;; Setup and Hooks -(defun start-server (port-file-namestring) +(defun start-server (port-file-namestring &optional (port 0)) "Create a SWANK server and write its port number to the file PORT-FILE-NAMESTRING in ascii text." - (let ((port (create-swank-server 0 :reuse-address t))) + (let ((port (create-swank-server port :reuse-address t))) (with-open-file (s port-file-namestring :direction :output :if-exists :overwrite @@ -42,6 +157,37 @@ (when *swank-debug-p* (format *debug-io* "~&;; Swank ready.~%"))) +(defcallback call-with-debugging-environment (function) + "Execute FUNCTION in an environment setup for debugging. +Calls to backend debugger callbacks will be made from the dynamic +environment created by this function.") + +(define-condition swank-debug-condition (serious-condition) + ((wrapped-condition :initarg :wrapped-condition + :reader wrapped-condition))) + +(defun swank-debugger-hook (condition hook) + (let ((*swank-debugger-condition* condition) + (*swank-debugger-hook* hook) + (*sldb-level* (1+ *sldb-level*))) + (call-with-debugging-environment #'sldb-loop))) + +(defun sldb-loop () + (let ((level *sldb-level*)) + (send-to-emacs (list* :debug *sldb-level* (debugger-info-for-emacs 0 1))) + (handler-bind ((swank-debug-condition + (lambda (condition) + (let ((real-condition (wrapped-condition condition))) + (send-to-emacs `(:debug-condition + ,(princ-to-string real-condition)))) + (throw 'sldb-loop-catcher nil)))) + (unwind-protect + (loop (catch 'sldb-loop-catcher + (with-simple-restart + (abort "Return to sldb level ~D." level) + (read-from-emacs)))) + (send-to-emacs `(:debug-return ,level)))))) + ;;; IO to emacs (defvar *emacs-io* nil @@ -60,7 +206,9 @@ (defun read-from-emacs () "Read and process a request from Emacs." + (format t "~&Reading request.~%") (let ((form (read-next-form))) + (format t "~&Form = ~S~%" form) (if *redirect-output* (let ((*standard-output* *slime-output*) (*error-output* *slime-output*) @@ -76,15 +224,17 @@ S-expression to be evaluated to handle the request. If an error occurs during parsing, it will be noted and control will be tranferred back to the main request handling loop." + (format t "~&READ-NEXT-FORM 1~%") (flet ((next-byte () (char-code (read-char *emacs-io*)))) (handler-case (let* ((length (logior (ash (next-byte) 16) (ash (next-byte) 8) (next-byte))) (string (make-string length))) + (format t "~&READ-NEXT-FORM 2~%") (read-sequence string *emacs-io*) (read-form string)) - (condition (c) + (serious-condition (c) (throw 'serve-request-catcher c))))) (defun read-form (string) @@ -151,14 +301,6 @@ (error "Backend function ~A not implemented." ',fun)) (export ',fun :swank))) -(defvar *swank-debugger-condition*) -(defvar *swank-debugger-hook*) - -(defun swank-debugger-hook (condition hook) - (let ((*swank-debugger-condition* condition) - (*swank-debugger-hook* hook)) - (sldb-loop))) - (defslimefun eval-string (string buffer-package) (let ((*debugger-hook* #'swank-debugger-hook)) (let (ok result) @@ -169,6 +311,10 @@ (force-output) (setq ok t)) (send-to-emacs (if ok `(:ok ,result) '(:aborted))))))) + +(defslimefun oneway-eval-string (string buffer-package) + (let ((*buffer-package* (guess-package-from-string buffer-package))) + (eval (read-form string)))) (defslimefun interactive-eval (string) (let ((values (multiple-value-list (eval (from-string string))))) Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.12 slime/swank-cmucl.lisp:1.12.2.1 --- slime/swank-cmucl.lisp:1.12 Fri Oct 24 21:54:00 2003 +++ slime/swank-cmucl.lisp Sun Oct 26 23:04:56 2003 @@ -1,7 +1,22 @@ (declaim (optimize debug)) -(in-package :swank) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defpackage :swank-cmucl + (:use :common-lisp) + (:nicknames "SWANK-BACKEND"))) + +(in-package :swank-cmucl) + +(import '(swank:*swank-debugger-condition* swank:*sldb-level* +swank:*buffer-package* swank:*compiler-notes* swank:*notes-database* +swank:*previous-compiler-condition* swank:*previous-context* +swank:*sldb-level* swank:*swank-debugger-condition* +swank:apply-macro-expander swank:backtrace-for-emacs +swank:call-with-compilation-hooks swank:clear-note-database +swank:from-string swank:print-description-to-string swank:to-string +swank:*emacs-io* swank:*slime-output* swank:*slime-input* swank:*slime-io*)) + ;;; Setup and hooks. @@ -29,7 +44,7 @@ (unless (zerop (lisp::string-output-stream-index stream)) (setf (slime-output-stream-last-charpos stream) (slime-out-misc stream :charpos)) - (send-to-emacs `(:read-output ,(get-output-stream-string stream))))) + (swank:send-to-emacs `(:read-output ,(get-output-stream-string stream))))) (:file-position nil) (:charpos (do ((index (1- (the fixnum (lisp::string-output-stream-index stream))) @@ -57,19 +72,20 @@ (defun slime-input-stream/n-bin (stream buffer start requested eof-errorp) (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*))) - (send-to-emacs `(:read-input ,requested ,*read-input-catch-tag*)) + (swank:send-to-emacs `(:read-input ,requested ,*read-input-catch-tag*)) (let ((input (catch *read-input-catch-tag* - (read-from-emacs)))) + (swank:read-from-emacs)))) (loop for c across input for i from start do (setf (aref buffer i) (char-code c))) (length input)))) -(defslimefun take-input (tag input) +(defun swank:take-input (tag input) (throw tag input)) -(defun create-swank-server (port &key reuse-address (address "localhost")) +(defun swank:create-swank-server (port &key reuse-address (address "localhost")) "Create a SWANK TCP server." + (dribble "/tmp/swank.log") (let* ((hostent (ext:lookup-host-entry address)) (address (car (ext:host-entry-addr-list hostent))) (ip (ext:htonl address))) @@ -103,10 +119,10 @@ The request is read from the socket as a sexp and then evaluated." (let ((completed nil)) (let ((condition (catch 'serve-request-catcher - (read-from-emacs) + (swank:read-from-emacs) (setq completed t)))) (unless completed - (when *swank-debug-p* + (when swank:*swank-debug-p* (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" condition)) (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*)) @@ -114,7 +130,7 @@ ;;; -(defslimefun set-default-directory (directory) +(defun swank:set-default-directory (directory) (setf (ext:default-directory) (namestring directory)) ;; Setting *default-pathname-defaults* to an absolute directory ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. @@ -198,13 +214,13 @@ (reverse (c::compiler-error-context-original-source-path context))))) -(defun call-trapping-compilation-notes (fn) +(defun swank:call-trapping-compilation-notes (fn) (handler-bind ((c::compiler-error #'handle-notification-condition) (c::style-warning #'handle-notification-condition) (c::warning #'handle-notification-condition)) (funcall fn))) -(defslimefun swank-compile-file (filename load) +(defun swank:swank-compile-file (filename load) (call-with-compilation-hooks (lambda () (clear-note-database filename) @@ -213,7 +229,7 @@ (*buffer-offset* nil)) (compile-file filename :load load))))) -(defslimefun swank-compile-string (string buffer start) +(defun swank:swank-compile-string (string buffer start) (call-with-compilation-hooks (lambda () (let ((*package* *buffer-package*) @@ -254,14 +270,14 @@ (defun unix-truename (pathname) (ext:unix-namestring (truename pathname))) -(defslimefun arglist-string (fname) +(defun swank:arglist-string (fname) "Return a string describing the argument list for FNAME. The result has the format \"(...)\"." (declare (type string fname)) (multiple-value-bind (function condition) (ignore-errors (values (from-string fname))) (when condition - (return-from arglist-string (format nil "(-- ~A)" condition))) + (return-from swank:arglist-string (format nil "(-- ~A)" condition))) (let ((arglist (if (not (or (fboundp function) (functionp function))) @@ -287,24 +303,24 @@ arglist (to-string arglist))))) -(defslimefun who-calls (function-name) +(defun swank:who-calls (function-name) "Return the places where FUNCTION-NAME is called." (xref-results-for-emacs (xref:who-calls function-name))) -(defslimefun who-references (variable) +(defun swank:who-references (variable) "Return the places where the global variable VARIABLE is referenced." (xref-results-for-emacs (xref:who-references variable))) -(defslimefun who-binds (variable) +(defun swank:who-binds (variable) "Return the places where the global variable VARIABLE is bound." (xref-results-for-emacs (xref:who-binds variable))) -(defslimefun who-sets (variable) +(defun swank:who-sets (variable) "Return the places where the global variable VARIABLE is set." (xref-results-for-emacs (xref:who-sets variable))) #+cmu19 -(defslimefun who-macroexpands (macro) +(defun swank:who-macroexpands (macro) "Return the places where MACRO is expanded." (xref-results-for-emacs (xref:who-macroexpands macro))) @@ -421,10 +437,10 @@ (let ((*print-pretty* nil)) (mapcar #'to-string (remove-if-not #'ext:valid-function-name-p list)))) -(defslimefun list-callers (symbol-name) +(defun swank:list-callers (symbol-name) (stringify-function-name-list (function-callers (from-string symbol-name)))) -(defslimefun list-callees (symbol-name) +(defun swank:list-callees (symbol-name) (stringify-function-name-list (function-callees (from-string symbol-name)))) ;;;; Definitions @@ -492,7 +508,7 @@ (when location (source-location-for-emacs location)))))) -(defslimefun function-source-location-for-emacs (fname) +(defun swank:function-source-location-for-emacs (fname) "Return the source-location of FNAME's definition." (let* ((fname (from-string fname)) (finder @@ -545,21 +561,21 @@ (if result (list* :designator (to-string symbol) result))))) -(defslimefun describe-setf-function (symbol-name) +(defun swank:describe-setf-function (symbol-name) (print-description-to-string (or (ext:info setf inverse (from-string symbol-name)) (ext:info setf expander (from-string symbol-name))))) -(defslimefun describe-type (symbol-name) +(defun swank:describe-type (symbol-name) (print-description-to-string (kernel:values-specifier-type (from-string symbol-name)))) -(defslimefun describe-class (symbol-name) +(defun swank:describe-class (symbol-name) (print-description-to-string (find-class (from-string symbol-name) nil))) ;;; Macroexpansion -(defslimefun swank-macroexpand-all (string) +(defun swank:swank-macroexpand-all (string) (apply-macro-expander #'walker:macroexpand-all string)) @@ -569,7 +585,7 @@ (gethash (debug::trace-fdefinition fname) debug::*traced-functions*)) -(defslimefun toggle-trace-fdefinition (fname-string) +(defun swank:toggle-trace-fdefinition (fname-string) (let ((fname (from-string fname-string))) (cond ((tracedp fname) (debug::untrace-1 fname) @@ -581,14 +597,28 @@ ;;; Debugging -(defvar *sldb-level* 0) (defvar *sldb-stack-top*) (defvar *sldb-restarts*) -(defslimefun getpid () +(defun swank:getpid () (unix:unix-getpid)) -(defslimefun sldb-loop () +(defun swank:call-with-debugging-environment (function) + (unix:unix-sigsetmask 0) + (let ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) + (*sldb-restarts* (compute-restarts swank:*swank-debugger-condition*)) + (debug:*stack-top-hint* nil) + (*readtable* (or debug:*debug-readtable* *readtable*)) + (*print-level* debug:*debug-print-level*) + (*print-length* debug:*debug-print-length*)) + (handler-bind ((di:debug-condition + (lambda (condition) + (signal 'swank-debug-condition + :wrapped-condition condition)))) + (funcall function)))) + +#+nil +(defun swank:sldb-loop () (unix:unix-sigsetmask 0) (let* ((*sldb-level* (1+ *sldb-level*)) (*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) @@ -600,18 +630,19 @@ (*readtable* (or debug:*debug-readtable* *readtable*)) (*print-level* debug:*debug-print-level*) (*print-length* debug:*debug-print-length*)) - (send-to-emacs (list* :debug *sldb-level* (debugger-info-for-emacs 0 1))) + (swank:send-to-emacs + (list* :debug *sldb-level* (debugger-info-for-emacs 0 1))) (handler-bind ((di:debug-condition (lambda (condition) - (send-to-emacs `(:debug-condition + (swank:send-to-emacs `(:debug-condition ,(princ-to-string condition))) (throw 'sldb-loop-catcher nil)))) (unwind-protect (loop (catch 'sldb-loop-catcher (with-simple-restart (abort "Return to sldb level ~D." level) - (read-from-emacs)))) - (send-to-emacs `(:debug-return ,level)))))) + (swank:read-from-emacs)))) + (swank:send-to-emacs `(:debug-return ,level)))))) (defun format-restarts-for-emacs () "Return a list of restarts for *swank-debugger-condition* in a @@ -631,7 +662,12 @@ ((zerop i) frame))) (defun nth-restart (index) - (nth index *sldb-restarts*)) + (or (nth index *sldb-restarts*) + (signal 'swank-debug-condition + :wrapped-condition + (make-condition 'simple-condition + :format-control "Restart out of bounds: ~S" + :format-arguments (list index))))) (defun format-frame-for-emacs (frame) (list (di:frame-number frame) @@ -655,10 +691,10 @@ while f collect f))) -(defslimefun backtrace-for-emacs (start end) +(defun swank:backtrace-for-emacs (start end) (mapcar #'format-frame-for-emacs (compute-backtrace start end))) -(defslimefun debugger-info-for-emacs (start end) +(defun swank:debugger-info-for-emacs (start end) (list (format-condition-for-emacs) (format-restarts-for-emacs) (backtrace-length) @@ -716,13 +752,13 @@ (handler-case (source-location-for-emacs code-location) (t (c) (list :error (debug::safe-condition-message c))))) -(defslimefun frame-source-location-for-emacs (index) +(defun swank:frame-source-location-for-emacs (index) (safe-source-location-for-emacs (di:frame-code-location (nth-frame index)))) -(defslimefun eval-string-in-frame (string index) +(defun swank:eval-string-in-frame (string index) (to-string (di:eval-in-frame (nth-frame index) (from-string string)))) -(defslimefun frame-locals (index) +(defun swank:frame-locals (index) (let* ((frame (nth-frame index)) (location (di:frame-code-location frame)) (debug-function (di:frame-debug-function frame)) @@ -738,20 +774,21 @@ (to-string (di:debug-variable-value v frame)) ""))))) -(defslimefun frame-catch-tags (index) +(defun swank:frame-catch-tags (index) (loop for (tag . code-location) in (di:frame-catches (nth-frame index)) collect `(,tag . ,(safe-source-location-for-emacs code-location)))) -(defslimefun invoke-nth-restart (index) - (invoke-restart (nth-restart index))) +(defun swank:invoke-nth-restart (sldb-level index) + (when (eql sldb-level *sldb-level*) + (invoke-restart (nth-restart index)))) -(defslimefun sldb-continue () +(defun swank:sldb-continue () (continue *swank-debugger-condition*)) -(defslimefun sldb-abort () +(defun swank:sldb-abort () (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) -(defslimefun throw-to-toplevel () +(defun swank:throw-to-toplevel () (throw 'lisp::top-level-catcher nil)) @@ -769,7 +806,7 @@ (setq *inspector-stack* nil) (setf (fill-pointer *inspector-history*) 0)) -(defslimefun init-inspector (string) +(defun swank:init-inspector (string) (reset-inspector) (inspect-object (eval (from-string string)))) @@ -836,10 +873,10 @@ (defun nth-part (index) (cdr (nth index *inspectee-parts*))) -(defslimefun inspect-nth-part (index) +(defun swank:inspect-nth-part (index) (inspect-object (nth-part index))) -(defslimefun inspector-pop () +(defun swank:inspector-pop () "Drop the inspector stack and inspect the second element. Return nil if there's no second element." (cond ((cdr *inspector-stack*) @@ -847,18 +884,18 @@ (inspect-object (pop *inspector-stack*))) (t nil))) -(defslimefun inspector-next () +(defun swank:inspector-next () "Inspect the next element in the *inspector-history*." (let ((position (position *inspectee* *inspector-history*))) (cond ((= (1+ position) (length *inspector-history*)) nil) (t (inspect-object (aref *inspector-history* (1+ position))))))) -(defslimefun quit-inspector () +(defun swank:quit-inspector () (reset-inspector) nil) -(defslimefun describe-inspectee () +(defun swank:describe-inspectee () "Describe the currently inspected object." (print-description-to-string *inspectee*)) Index: slime/slime.el diff -u slime/slime.el:1.59 slime/slime.el:1.59.2.1 --- slime/slime.el:1.59 Fri Oct 24 21:54:00 2003 +++ slime/slime.el Sun Oct 26 23:04:56 2003 @@ -992,7 +992,9 @@ (assert (= sldb-level 0))) ((:emacs-evaluate form-string package-name continuation) (slime-output-evaluate-request form-string package-name) - (slime-push-state (slime-evaluating-state continuation)))) + (slime-push-state (slime-evaluating-state continuation))) + ((:emacs-evaluate-oneway form-string package-name) + (slime-output-oneway-evaluate-request form-string package-name))) (defvar slime-evaluating-state-activation-hook nil "Hook called when the evaluating state is actived.") @@ -1056,10 +1058,14 @@ (delete-windows-on sldb-buffer) (kill-buffer sldb-buffer)))) (slime-pop-state)) + ((:debug-condition reason) + (message reason)) ((:emacs-evaluate form-string package-name continuation) ;; recursive evaluation request (slime-output-evaluate-request form-string package-name) - (slime-push-state (slime-evaluating-state continuation)))) + (slime-push-state (slime-evaluating-state continuation))) + ((:emacs-evaluate-oneway form-string package-name) + (slime-output-oneway-evaluate-request form-string package-name))) (slime-defstate slime-read-input-state (request tag) "Reading state. @@ -1080,6 +1086,10 @@ "Send a request for LISP to read and evaluate FORM-STRING in PACKAGE-NAME." (slime-net-send `(swank:eval-string ,form-string ,package-name))) +(defun slime-output-oneway-evaluate-request (form-string package-name) + "Send a request for LISP to read and evaluate FORM-STRING in PACKAGE-NAME." + (slime-net-send `(swank:oneway-eval-string ,form-string ,package-name))) + (defun slime-check-connected () (unless (slime-connected-p) (error "Not connected. Use `M-x slime' to start a Lisp."))) @@ -1137,6 +1147,14 @@ (while (slime-busy-p) (accept-process-output slime-net-process))) +(defun slime-oneway-eval (sexp &optional package) + "Evaluate SEXP \"one-way\" - without receiving a return value." + (slime-check-connected) + (when (slime-busy-p) + (error "Busy evaluating")) + (slime-dispatch-event + `(:emacs-evaluate-oneway ,(prin1-to-string sexp) ,package))) + (defun slime-busy-p () "Return true if Lisp is busy processing a request." (eq (slime-state-name (slime-current-state)) 'slime-evaluating-state)) @@ -2700,7 +2718,7 @@ (let ((restart (or number (sldb-restart-at-point) (error "No restart at point")))) - (slime-eval-async `(swank:invoke-nth-restart ,restart) nil (lambda ())))) + (slime-oneway-eval `(swank:invoke-nth-restart ,sldb-level ,restart) nil))) (defun sldb-restart-at-point () (get-text-property (point) 'restart-number)) From jbielman at common-lisp.net Tue Oct 28 19:11:59 2003 From: jbielman at common-lisp.net (James Bielman) Date: Tue, 28 Oct 2003 14:11:59 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22065 Modified Files: swank-openmcl.lisp Log Message: * swank-openmcl.lisp: Pre-refactoring updates to the OpenMCL backend: (map-backtrace): Renamed from DO-BACKTRACE. (frame-source-location-for-emacs): New function. (function-source-location-for-emacs): New function, * swank-openmcl.lisp: Docstring updates/additions. Date: Tue Oct 28 14:11:58 2003 Author: jbielman Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.12 slime/swank-openmcl.lisp:1.13 --- slime/swank-openmcl.lisp:1.12 Fri Oct 24 21:54:00 2003 +++ slime/swank-openmcl.lisp Tue Oct 28 14:11:58 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.12 2003/10/25 01:54:00 lgorrie Exp $ +;;; $Id: swank-openmcl.lisp,v 1.13 2003/10/28 19:11:58 jbielman Exp $ ;;; ;;; @@ -31,7 +31,8 @@ ;;; * Evaluation of forms with C-M-x. ;;; * Compilation of defuns with C-c C-c. ;;; * File compilation with C-c C-k. -;;; * Basic debugger functionality, jumping to frames is not implemented yet. +;;; * 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. @@ -42,7 +43,8 @@ ;;; 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. +;;; caller is defined in---source location information is not +;;; available. ;;; ;;; Things that aren't done yet: ;;; @@ -130,6 +132,7 @@ (setq *swank-debugger-stack-frame* error-pointer)) (defslimefun arglist-string (fname) + "Return the lambda list for function FNAME as a string." (let ((*print-case* :downcase)) (multiple-value-bind (function condition) (ignore-errors (values (from-string fname))) @@ -163,13 +166,19 @@ (muffle-warning condition)) (defun call-trapping-compilation-notes (fn) + "Call FN trapping compiler notes and storing them in the notes database." (handler-bind ((ccl::compiler-warning #'handle-compiler-warning)) (funcall fn))) (defun temp-file-name () + "Return a temporary file name to compile strings into." (ccl:%get-cstring (#_tmpnam (ccl:%null-ptr)))) (defslimefun swank-compile-string (string buffer start) + "Compile STRING, using BUFFER and START as information for +reporting back the location of compiler notes. In OpenMCL we +have to use the file compiler to get compiler warning positions, +so we write the string to a temporary file and compile it." (declare (ignore buffer)) (let ((*buffer-offset* start) (*package* *buffer-package*) @@ -185,6 +194,7 @@ (delete-file filename)))))) (defslimefun swank-compile-file (filename load) + "Compile and optionally load FILENAME, trapping compiler notes for Emacs." (let ((*buffer-offset* 0)) (call-with-compilation-hooks (lambda () @@ -197,6 +207,7 @@ (defvar *sldb-restarts*) (defslimefun getpid () + "Return the process ID of this superior Lisp." (ccl::getpid)) (defslimefun sldb-loop () @@ -228,9 +239,9 @@ (format nil "~A~% [Condition of type ~S]" *swank-debugger-condition* (type-of *swank-debugger-condition*))) -(defun do-backtrace (function &optional - (start-frame-number 0) - (end-frame-number most-positive-fixnum)) +(defun map-backtrace (function &optional + (start-frame-number 0) + (end-frame-number most-positive-fixnum)) "Call FUNCTION passing information about each stack frame from frames START-FRAME-NUMBER to END-FRAME-NUMBER." (let ((tcr (ccl::%current-tcr)) @@ -251,9 +262,9 @@ (defun backtrace-length () "Return the total number of frames available in the debugger." (let ((result 0)) - (do-backtrace #'(lambda (n p tcr lfun pc) - (declare (ignore n p tcr lfun pc)) - (incf result))) + (map-backtrace #'(lambda (n p tcr lfun pc) + (declare (ignore n p tcr lfun pc)) + (incf result))) result)) (defun frame-arguments (p tcr lfun pc) @@ -302,13 +313,13 @@ If the backtrace cannot be calculated, this function returns NIL." (let (result) - (do-backtrace #'(lambda (frame-number p tcr lfun pc) - (push (list frame-number - (format nil "~D: (~A~A)" frame-number - (ccl::%lfun-name-string lfun) - (frame-arguments p tcr lfun pc))) + (map-backtrace #'(lambda (frame-number p tcr lfun pc) + (push (list frame-number + (format nil "~D: (~A~A)" frame-number + (ccl::%lfun-name-string lfun) + (frame-arguments p tcr lfun pc))) result)) - start-frame-number end-frame-number) + start-frame-number end-frame-number) (nreverse result))) (defslimefun debugger-info-for-emacs (start end) @@ -318,29 +329,52 @@ (backtrace-for-emacs start end))) (defslimefun frame-locals (index) - (do-backtrace - #'(lambda (frame-number p tcr lfun pc) - (when (= frame-number index) - (multiple-value-bind (count vsp parent-vsp) + (map-backtrace + #'(lambda (frame-number p tcr lfun pc) + (when (= frame-number index) + (multiple-value-bind (count vsp parent-vsp) (ccl::count-values-in-frame p tcr) - (let (result) - (dotimes (i count) - (multiple-value-bind (var type name) - (ccl::nth-value-in-frame p i tcr lfun pc vsp parent-vsp) - (declare (ignore type)) - (when name - (push (list - :symbol name - :id 0 - :validity :valid - :value-string (to-string var)) - result)))) - (return-from frame-locals (nreverse result)))))))) + (let (result) + (dotimes (i count) + (multiple-value-bind (var type name) + (ccl::nth-value-in-frame p i tcr lfun pc vsp parent-vsp) + (declare (ignore type)) + (when name + (push (list + :symbol (to-string name) + :id 0 + :validity :valid + :value-string (to-string var)) + result)))) + (return-from frame-locals (nreverse result)))))))) (defslimefun frame-catch-tags (index) (declare (ignore index)) nil) +(defun function-source-location (symbol) + "Return a plist containing a source location for the function +named SYMBOL." + (let ((source-info (ccl::%source-files symbol))) + ;; This is not entirely correct---%SOURCE-FILES can apparently + ;; return a list under some circumstances... + (when (and source-info (atom source-info)) + (let ((filename (namestring (truename source-info)))) + (list :from :file :filename filename :source-path '(0) :position 0 + :function-name (symbol-name symbol)))))) + +(defslimefun frame-source-location-for-emacs (index) + "Return to Emacs the location of the source code for the +function in a debugger frame. In OpenMCL, we are not able to +find the precise position of the frame, but we do attempt to give +at least the filename containing it." + (map-backtrace + #'(lambda (frame-number p tcr lfun pc) + (declare (ignore p tcr pc)) + (when (and (= frame-number index) lfun) + (return-from frame-source-location-for-emacs + (function-source-location (ccl:function-name lfun))))))) + (defun nth-restart (index) (nth index *sldb-restarts*)) @@ -426,9 +460,13 @@ (defslimefun-unimplemented who-macroexpands (symbol-name package-name)) (defslimefun-unimplemented find-fdefinition (symbol-name package-name)) -(defslimefun-unimplemented function-source-location-for-emacs (fname)) + +(defslimefun function-source-location-for-emacs (fname) + "Return a source position of the definition of FNAME. The +precise location of the definition is not available, but we are +able to return the file name in which the definition occurs." + (function-source-location (from-string fname))) ;;; Macroexpansion (defslimefun-unimplemented swank-macroexpand-all (string)) - From jbielman at common-lisp.net Tue Oct 28 19:12:36 2003 From: jbielman at common-lisp.net (James Bielman) Date: Tue, 28 Oct 2003 14:12:36 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22168 Modified Files: ChangeLog Log Message: Date: Tue Oct 28 14:12:31 2003 Author: jbielman Index: slime/ChangeLog diff -u slime/ChangeLog:1.66 slime/ChangeLog:1.67 --- slime/ChangeLog:1.66 Fri Oct 24 21:54:00 2003 +++ slime/ChangeLog Tue Oct 28 14:12:27 2003 @@ -1,3 +1,12 @@ +2003-10-28 James Bielman + + * swank-openmcl.lisp: Pre-refactoring updates to the OpenMCL backend: + (map-backtrace): Renamed from DO-BACKTRACE. + (frame-source-location-for-emacs): New function. + (function-source-location-for-emacs): New function, + + * swank-openmcl.lisp: Docstring updates/additions. + 2003-10-25 Luke Gorrie * Everywhere: Changed the connection setup to use a dynamic From jbielman at common-lisp.net Tue Oct 28 22:30:40 2003 From: jbielman at common-lisp.net (James Bielman) Date: Tue, 28 Oct 2003 17:30:40 -0500 Subject: [slime-cvs] CVS update: slime/null-swank-impl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14086 Added Files: null-swank-impl.lisp Log Message: New file, empty implementation of swank-impl. Date: Tue Oct 28 17:30:40 2003 Author: jbielman From jbielman at common-lisp.net Tue Oct 28 22:30:48 2003 From: jbielman at common-lisp.net (James Bielman) Date: Tue, 28 Oct 2003 17:30:48 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14125 Modified Files: ChangeLog Log Message: Date: Tue Oct 28 17:30:47 2003 Author: jbielman Index: slime/ChangeLog diff -u slime/ChangeLog:1.67 slime/ChangeLog:1.68 --- slime/ChangeLog:1.67 Tue Oct 28 14:12:27 2003 +++ slime/ChangeLog Tue Oct 28 17:30:47 2003 @@ -1,5 +1,7 @@ 2003-10-28 James Bielman + * null-swank-impl.lisp: New file. + * swank-openmcl.lisp: Pre-refactoring updates to the OpenMCL backend: (map-backtrace): Renamed from DO-BACKTRACE. (frame-source-location-for-emacs): New function. From jbielman at common-lisp.net Tue Oct 28 23:37:14 2003 From: jbielman at common-lisp.net (James Bielman) Date: Tue, 28 Oct 2003 18:37:14 -0500 Subject: [slime-cvs] CVS update: slime/null-swank-impl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14622 Modified Files: null-swank-impl.lisp Log Message: Rename COMPILE-STREAM to COMPILE-STREAM-TRAPPING-CONDITIONS. Add function COMPILE-FILE-TRAPPING-CONDITIONS for file compilation. Date: Tue Oct 28 18:37:14 2003 Author: jbielman Index: slime/null-swank-impl.lisp diff -u slime/null-swank-impl.lisp:1.1 slime/null-swank-impl.lisp:1.2 --- slime/null-swank-impl.lisp:1.1 Tue Oct 28 17:30:39 2003 +++ slime/null-swank-impl.lisp Tue Oct 28 18:37:14 2003 @@ -5,7 +5,7 @@ ;;; Copyright (C) 2003, James Bielman ;;; Released into the public domain; all warranties are disclaimed. ;;; -;;; $Id: null-swank-impl.lisp,v 1.1 2003/10/28 22:30:39 jbielman Exp $ +;;; $Id: null-swank-impl.lisp,v 1.2 2003/10/28 23:37:14 jbielman Exp $ ;;; ;; The "SWANK-IMPL" package contains functions that access the naughty @@ -59,7 +59,8 @@ (:export #:backtrace #:backtrace-length - #:compile-stream + #:compile-file-trapping-conditions + #:compile-stream-trapping-conditions #:compiler-condition #:compiler-condition-message #:compiler-condition-original-condition @@ -157,11 +158,15 @@ ;;; Compilation -;; XXX I have this as the only entry point for doing compilation---do -;; we want to have our own version of COMPILE-FILE that resignals -;; portable compiler-conditions as well or is this enough? +(defun compile-file-trapping-conditions (filename &key (load t)) + "Compile FILENAME like COMPILE-FILE but resignal compilation +conditions as Swank compiler conditions." + (declare (ignore filename load)) + (error 'not-implemented-error + :function-name 'compile-file-trapping-conditions)) -(defun compile-stream (stream &key filename position (load t)) +(defun compile-stream-trapping-conditions (stream &key + filename position (load t)) "Compile source from STREAM. During compilation, compiler conditions must be trapped and resignalled as COMPILER-CONDITIONs. @@ -173,7 +178,8 @@ Additionally, if POSITION is supplied, it must be added to source positions reported in compiler conditions." (declare (ignore stream filename position load)) - (error 'not-implemented-error :function-name 'compile-stream)) + (error 'not-implemented-error + :function-name 'compile-stream-trapping-conditions)) ;;; Symbol and Function Introspection From lgorrie at common-lisp.net Wed Oct 29 04:48:56 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 28 Oct 2003 23:48:56 -0500 Subject: [slime-cvs] CVS update: slime/slime.el slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13002 Modified Files: slime.el ChangeLog Log Message: Date: Tue Oct 28 23:48:55 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.59 slime/slime.el:1.60 --- slime/slime.el:1.59 Fri Oct 24 21:54:00 2003 +++ slime/slime.el Tue Oct 28 23:48:55 2003 @@ -740,7 +740,8 @@ (process-send-string slime-net-process (string-make-unibyte string)))) (defun slime-net-sentinel (process message) - (message "Lisp connection closed: %s" message) + (when (ignore-errors (process-live-p (inferior-lisp-proc))) + (message "Lisp connection closed unexpectedly: %s" message)) (setq slime-state-name "[not connected]") (force-mode-line-update) (ignore-errors (kill-buffer (process-buffer slime-net-process)))) Index: slime/ChangeLog diff -u slime/ChangeLog:1.68 slime/ChangeLog:1.69 --- slime/ChangeLog:1.68 Tue Oct 28 17:30:47 2003 +++ slime/ChangeLog Tue Oct 28 23:48:55 2003 @@ -1,3 +1,8 @@ +2003-10-29 Luke Gorrie + + * slime.el (slime-net-sentinel): Only show a message about + disconnection if the inferior-lisp is still running. + 2003-10-28 James Bielman * null-swank-impl.lisp: New file. From lgorrie at common-lisp.net Wed Oct 29 16:54:31 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 29 Oct 2003 11:54:31 -0500 Subject: [slime-cvs] CVS update: slime/slime.el slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8452 Modified Files: Tag: backhackattack-1 slime.el ChangeLog Log Message: (slime-interrupt, slime-quit): Only send the quit/interrupt message to Lisp if it is in fact evaluating something for us. This fixes a protocol bug reported by Paolo Amoroso. Added (require 'pp). Date: Wed Oct 29 11:54:31 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.59.2.1 slime/slime.el:1.59.2.2 --- slime/slime.el:1.59.2.1 Sun Oct 26 23:04:56 2003 +++ slime/slime.el Wed Oct 29 11:54:31 2003 @@ -55,6 +55,7 @@ (require 'inf-lisp) (require 'cl) (require 'hyperspec) +(require 'pp) (when (featurep 'xemacs) (require 'overlay)) (unless (fboundp 'define-minor-mode) @@ -271,6 +272,14 @@ (insert ")"))) (comint-send-input)) +(defun inferior-slime-delete-char (arg) + "Delete ARG characters, or invoke ABORT restart if at end of buffer." + (interactive "p") + (if (not (eobp)) + (call-interactively 'delete-char (list arg)) + (message "Pop LISP one level") + (comint-send-string (get-buffer-process (current-buffer)) + "abort\n"))) ;;;;; Key bindings @@ -1159,6 +1168,10 @@ "Return true if Lisp is busy processing a request." (eq (slime-state-name (slime-current-state)) 'slime-evaluating-state)) +(defun slime-evaluating-p () + "Return true if Lisp is evaluating a request for Emacs." + (slime-busy-p)) + (defun slime-ping () "Check that communication works." (interactive) @@ -2350,11 +2363,15 @@ (defun slime-interrupt () (interactive) - (slime-dispatch-event '(:emacs-interrupt))) + (if (slime-evaluating-p) + (slime-dispatch-event '(:emacs-interrupt)) + (error "Not evaluating - nothing to interrupt."))) (defun slime-quit () (interactive) - (slime-dispatch-event '(:emacs-quit))) + (if (slime-evaluating-p) + (slime-dispatch-event '(:emacs-quit)) + (error "Not evaluating - nothing to quit."))) (defun slime-set-package (package) (interactive (list (slime-read-package-name "Package: " Index: slime/ChangeLog diff -u slime/ChangeLog:1.66 slime/ChangeLog:1.66.2.1 --- slime/ChangeLog:1.66 Fri Oct 24 21:54:00 2003 +++ slime/ChangeLog Wed Oct 29 11:54:31 2003 @@ -1,3 +1,11 @@ +2003-10-29 Luke Gorrie + + * slime.el (slime-interrupt, slime-quit): Only send the + quit/interrupt message to Lisp if it is in fact evaluating + something for us. This fixes a protocol bug reported by Paolo + Amoroso. + Added (require 'pp). + 2003-10-25 Luke Gorrie * Everywhere: Changed the connection setup to use a dynamic From heller at common-lisp.net Wed Oct 29 23:41:56 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 29 Oct 2003 18:41:56 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4136 Modified Files: slime.el Log Message: Beginnings of a REPL-mode. slime-repl-input-history, slime-repl-input-history-position, slime-repl-mode-map, slime-repl-prompt-start-mark, slime-repl-input-start-mark, slime-repl-input-end-mark: New variables. (slime-repl-mode, slime-repl-xxx): New functions. (slime-init-connection): Display the listener. (slime-idle-state): Display a prompt on activation. (slime-idle-p): New function. (slime-output-buffer, slime-insert-transcript-delimiter, slime-show-last-output, slime-switch-to-output-buffer, slime-show-output-buffer, slime-show-evaluation-result, slime-show-evaluation-result-continuation): Cooporate with the REPL. Minor debugger cleanups. (slime-debugging-state): Clear buffers on every :debug-return. (sldb-inspect-in-frame): New command. (slime-display-buffer-region): Don't resize if there is only one window left. Date: Wed Oct 29 18:41:55 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.60 slime/slime.el:1.61 --- slime/slime.el:1.60 Tue Oct 28 23:48:55 2003 +++ slime/slime.el Wed Oct 29 18:41:55 2003 @@ -387,7 +387,6 @@ (display-buffer (current-buffer) t)) (comint-postoutput-scroll-to-bottom string))))) - ;;; Common utility functions and macros @@ -679,7 +678,8 @@ (defun slime-init-connection () (slime-init-dispatcher) (setq slime-pid (slime-eval '(swank:getpid))) - (slime-fetch-features-list)) + (slime-fetch-features-list) + (slime-repl)) (defun slime-fetch-features-list () "Fetch and remember the *FEATURES* of the inferior lisp." @@ -990,7 +990,8 @@ (slime-defstate slime-idle-state () "Idle state. The only event allowed is to make a request." ((activate) - (assert (= sldb-level 0))) + (assert (= sldb-level 0)) + (slime-repl-maybe-prompt)) ((:emacs-evaluate form-string package-name continuation) (slime-output-evaluate-request form-string package-name) (slime-push-state (slime-evaluating-state continuation)))) @@ -1046,16 +1047,8 @@ (sldb-setup condition restarts depth frames)))) ((:debug-return level) (assert (= level sldb-level)) - ;; We must decrement here so we will notice when we are - ;; activated again, especially when we continue from the - ;; debugger and are activated a second time without entering - ;; a lower break level. + (sldb-cleanup) (decf sldb-level) - (when (= level 1) - (let ((sldb-buffer (get-buffer "*sldb*"))) - (when sldb-buffer - (delete-windows-on sldb-buffer) - (kill-buffer sldb-buffer)))) (slime-pop-state)) ((:emacs-evaluate form-string package-name continuation) ;; recursive evaluation request @@ -1142,6 +1135,10 @@ "Return true if Lisp is busy processing a request." (eq (slime-state-name (slime-current-state)) 'slime-evaluating-state)) +(defun slime-idle-p () + "Return true if Lisp is idle." + (eq (slime-state-name (slime-current-state)) 'slime-idle-state)) + (defun slime-ping () "Check that communication works." (interactive) @@ -1155,52 +1152,206 @@ (defun slime-output-buffer () "Return the output buffer, create it if necessary." - (or (get-buffer "*slime-messages*") - (with-current-buffer (get-buffer-create "*slime-messages*") - (slime-mode t) + (or (get-buffer "*slime-repl*") + (with-current-buffer (get-buffer-create "*slime-repl*") + (slime-repl-mode) + (slime-repl-insert-prompt) (current-buffer)))) -(defun slime-output-buffer-position () - (with-current-buffer (slime-output-buffer) (point-max))) - (defun slime-insert-transcript-delimiter (string) (with-current-buffer (slime-output-buffer) (goto-char (point-max)) - (insert "\n;;;; " - (subst-char-in-string ?\n ?\ - (substring string 0 - (min 60 (length string)))) - " ...\n") + (slime-repl-maybe-insert-output-separator) + (slime-insert-propertized + '(slime-transcript-delimiter t) + "\n;;;; " + (subst-char-in-string ?\n ?\ + (substring string 0 + (min 60 (length string)))) + " ...\n") (set-marker slime-last-output-start (point) (current-buffer)))) -(defun slime-show-last-output (&optional output-start) - (let ((output-start (or output-start - (marker-position slime-last-output-start)))) - (when (< output-start (slime-output-buffer-position)) - (slime-display-buffer-region - (slime-output-buffer) - output-start (slime-output-buffer-position) - 1)))) +(defun slime-show-last-output () + (with-current-buffer (slime-output-buffer) + (let ((output-start slime-last-output-start) + (prompt-start slime-repl-prompt-start-mark)) + (when (< output-start prompt-start) + (slime-display-buffer-region (current-buffer) + output-start prompt-start))))) (defun slime-output-string (string) (unless (zerop (length string)) (with-current-buffer (slime-output-buffer) (goto-char (point-max)) + (slime-repl-maybe-insert-output-separator) (insert string)))) (defun slime-switch-to-output-buffer () "Select the output buffer, preferably in a different window." (interactive) - (slime-save-window-configuration) - (pop-to-buffer (slime-output-buffer) nil t)) + (switch-to-buffer-other-window (slime-output-buffer)) + (goto-char (point-max))) (defun slime-show-output-buffer () (slime-show-last-output) (with-current-buffer (slime-output-buffer) - (goto-char (point-max)) (display-buffer (slime-output-buffer) t))) +;;; REPL + +(defvar slime-repl-input-history '() + "History list of strings read from the REPL buffer.") +(defvar slime-repl-input-history-position 0) +(defvar slime-repl-mode-map) + +(defvar slime-repl-prompt-start-mark (make-marker)) +(defvar slime-repl-input-start-mark (make-marker)) +(defvar slime-repl-input-end-mark (let ((m (make-marker))) + (set-marker-insertion-type m t) + m)) + +(defun slime-repl-mode () + "Major mode for interacting with a superior Lisp. +\\{slime-repl-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map slime-repl-mode-map) + (lisp-mode-variables t) + (setq font-lock-defaults nil) + (setq mode-name "REPL") + (run-hooks 'slime-repl-mode-hook)) + +(defun slime-repl-insert-prompt () + (unless (bolp) (insert "\n")) + (set-marker slime-repl-prompt-start-mark (point) (current-buffer)) + (slime-insert-propertized + '(face font-lock-keyword-face + read-only t + intangible t + ;; emacs stuff + rear-nonsticky (slime-repl-prompt read-only face intangible) + ;; xemacs stuff + start-open t end-open t) + "lisp> ") + (set-marker slime-repl-input-start-mark (point) (current-buffer)) + (set-marker slime-repl-input-end-mark (point) (current-buffer))) + +(defun slime-repl-maybe-prompt () + "Insert a prompt if there is none." + (with-current-buffer (slime-output-buffer) + (unless (= (point-max) slime-repl-input-end-mark) + (goto-char (point-max)) + (slime-repl-insert-prompt)))) + +(defun slime-repl-current-input () + "Return the current input as string. The input is the region from +after the last prompt to the end of buffer." + (buffer-substring-no-properties slime-repl-input-start-mark + slime-repl-input-end-mark)) + +(defun slime-repl-eval-string (string) + (push string slime-repl-input-history) + (setq slime-repl-input-history-position -1) + (slime-eval-async + `(swank:interactive-eval-region ,string) + nil + (slime-repl-show-result-continutation))) + +(defun slime-repl-show-result-continutation () + ;; This is called _after_ the idle state is activated. This means + ;; the prompt is already printed. + (lambda (result) + (with-current-buffer (slime-output-buffer) + (goto-char slime-repl-prompt-start-mark) + (insert ";Value: " result "\n") + (goto-char (point-max))))) + +(defun slime-repl-maybe-insert-output-separator () + "Insert a newline character point, if we are the end of the input." + (when (= (point) slime-repl-input-end-mark) + (insert "\n") + (set-marker slime-repl-input-end-mark (1- (point)) (current-buffer)) + (set-marker slime-last-output-start (point)))) + +(defun slime-repl-return () + "Evaluate the current input string." + (interactive) + (unless (slime-idle-p) + (error "Lisp is not ready for request from the REPL.")) + (let ((input (slime-repl-current-input))) + (goto-char slime-repl-input-end-mark) + (slime-repl-maybe-insert-output-separator) + (add-text-properties slime-repl-input-start-mark + slime-repl-input-end-mark + '(face underline)) + (slime-repl-eval-string input))) + +(defun slime-repl-delete-current-input () + (delete-region slime-repl-input-start-mark slime-repl-input-end-mark)) + +(defun slime-repl-replace-input (string) + (slime-repl-delete-current-input) + (insert-and-inherit string)) + +(defun slime-repl-insert-from-history (fn) + (setq slime-repl-input-history-position + (funcall fn slime-repl-input-history-position)) + (slime-repl-replace-input + (nth slime-repl-input-history-position slime-repl-input-history))) + +(defun slime-repl-previous-input () + (interactive) + (unless (< (1+ slime-repl-input-history-position) + (length slime-repl-input-history)) + (error "End of history; no preceding item")) + (slime-repl-insert-from-history #'1+)) + +(defun slime-repl-next-input () + (interactive) + (unless (plusp slime-repl-input-history-position) + (error "End of history; no next item")) + (slime-repl-insert-from-history #'1-)) + +(defun slime-repl-matching-input (prompt bound increment error) + (let* ((regexp (read-from-minibuffer prompt)) + (pos (position-if + (lambda (string) (string-match regexp string)) + slime-repl-input-history + bound (funcall increment slime-repl-input-history-position)))) + (unless pos (error error)) + (setq slime-repl-input-history-position pos) + (slime-repl-insert-from-history #'identity))) + +(defun slime-repl-previous-matching-input () + (interactive) + (slime-repl-matching-input "Previous element matching (regexp): " + :start #'1+ + "No earlier matching history item")) + +(defun slime-repl-next-matching-input () + (interactive) + (slime-repl-matching-input "Next element matching (regexp): " + :end #'1- + "No later matching history item")) + +(defun slime-repl () + (interactive) + (slime-switch-to-output-buffer)) + +(setq slime-repl-mode-map (make-sparse-keymap)) +(set-keymap-parent slime-repl-mode-map lisp-mode-map) + +(slime-define-keys slime-repl-mode-map + ("\C-m" 'slime-repl-return) + ("\M-p" 'slime-repl-previous-input) + ("\M-n" 'slime-repl-next-input) + ("\M-r" 'slime-repl-previous-matching-input) + ("\M-s" 'slime-repl-next-matching-input) + ("\t" 'slime-complete-symbol) + (" " 'slime-space)) + + ;;; Compilation and the creation of compiler-note annotations (defun slime-compile-and-load-file () @@ -1616,8 +1767,8 @@ (interactive "p") (self-insert-command n) (when (and (slime-connected-p) - (not (slime-busy-p)) - (slime-function-called-at-point/line)) + (not (slime-busy-p)) + (slime-function-called-at-point/line)) (slime-arglist (symbol-name (slime-function-called-at-point/line))))) (defun slime-arglist (symbol-name) @@ -1660,7 +1811,7 @@ (ding)) ((not (string= prefix completion)) (delete-region beg end) - (insert completion)) + (insert-and-inherit completion)) (t (message "Making completion list...") (let ((list (all-completions prefix completions-alist nil))) @@ -1830,7 +1981,8 @@ ;; window is not selected.) (set-window-start win (point)) ;; don't resize vertically split windows - (when (= (window-width) (frame-width)) + (when (and (not (one-window-p)) + (= (window-width) (frame-width))) (let* ((lines (max (count-screen-lines (point) end) 1)) (new-height (1+ (min (/ (frame-height) 2) (+ border lines)))) @@ -1839,14 +1991,13 @@ (select-window win) (enlarge-window diff)))))))))) -(defun slime-show-evaluation-result (output-start value) +(defun slime-show-evaluation-result (value) (message "=> %s" value) - (slime-show-last-output output-start)) + (slime-show-last-output)) (defun slime-show-evaluation-result-continuation () - (lexical-let ((output-start (slime-output-buffer-position))) - (lambda (value) - (slime-show-evaluation-result output-start value)))) + (lambda (value) + (slime-show-evaluation-result value))) (defun slime-last-expression () (buffer-substring-no-properties (save-excursion (backward-sexp) (point)) @@ -2568,15 +2719,16 @@ (insert (second frame) "\n" indent1 "Locals:\n") (sldb-princ-locals frame-number indent2) - (let ((catchers (sldb-catch-tags frame-number))) - (cond ((null catchers) + (let ((catchers (sldb-catch-tags frame-number))) + (cond ((null catchers) (insert indent1 "[No catch-tags]\n")) - (t + (t (insert indent1 "Catch-tags:\n") - (loop for (tag . location) in catchers - do (slime-insert-propertized - '(catch-tag ,tag) - indent2 (format "%S\n" tag)))))) + (loop for (tag . location) in catchers + do (slime-insert-propertized + '(catch-tag ,tag) + indent2 (format "%S\n" tag)))))) + (terpri) (point))))) (apply #'sldb-maybe-recenter-region (sldb-frame-region))) @@ -2616,6 +2768,14 @@ (lambda (result) (slime-show-description result nil))))) +(defun sldb-inspect-in-frame (string) + (interactive (list (slime-read-from-minibuffer + "Inspect in frame (evaluated): "))) + (let ((number (sldb-frame-number-at-point))) + (slime-eval-async `(swank:inspect-in-frame ,string ,number) + (slime-buffer-package) + 'slime-open-inspector))) + (defun sldb-forward-frame () (goto-char (next-single-char-property-change (point) 'frame))) @@ -2675,11 +2835,13 @@ (defun sldb-list-catch-tags () (interactive) (slime-message "%S" (sldb-catch-tags (sldb-frame-number-at-point)))) - -(defun sldb-cleanup (buffer) - (delete-windows-on buffer) - (kill-buffer buffer)) +(defun sldb-cleanup () + (let ((sldb-buffer (get-buffer "*sldb*"))) + (when sldb-buffer + (delete-windows-on sldb-buffer) + (kill-buffer sldb-buffer)))) + (defun sldb-quit () (interactive) (slime-eval-async '(swank:throw-to-toplevel) nil (lambda (_)))) @@ -2712,6 +2874,7 @@ ([mouse-2] 'sldb-default-action/mouse) ("e" 'sldb-eval-in-frame) ("p" 'sldb-pprint-eval-in-frame) + ("i" 'sldb-inspect-in-frame) ("d" 'sldb-down) ("u" 'sldb-up) ("\M-n" 'sldb-details-down) @@ -3075,7 +3238,7 @@ (def-slime-test compile-defun (program subform) "Compile PROGRAM containing errors. - Confirm that SUBFORM is correctly located." +Confirm that SUBFORM is correctly located." '(("(defun :foo () (:bar))" (:bar)) ("(defun :foo () #\\space @@ -3100,7 +3263,7 @@ (slime-check error-location-correct (equal (read (current-buffer)) subform)))) - + (def-slime-test async-eval-debugging (depth) "Test recursive debugging of asynchronous evaluation requests." '((1) (2) (3)) @@ -3285,16 +3448,17 @@ limit (length object)) (with-current-buffer (or object (current-buffer)) - (let ((initial-value (get-char-property (1- position) prop object)) - (limit (or limit (point-min)))) + (let ((limit (or limit (point-min)))) (if (<= position limit) limit - (loop for pos = position then - (previous-char-property-change pos limit) - if (<= pos limit) return limit - if (not (eq initial-value - (get-char-property (1- pos) prop object))) - return pos))))))) + (let ((initial-value (get-char-property (1- position) + prop object))) + (loop for pos = position then + (previous-char-property-change pos limit) + if (<= pos limit) return limit + if (not (eq initial-value + (get-char-property (1- pos) prop object))) + return pos)))))))) (defun-if-undefined substring-no-properties (string &optional start end) (let* ((start (or start 0)) From heller at common-lisp.net Wed Oct 29 23:45:58 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 29 Oct 2003 18:45:58 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6445 Modified Files: swank-cmucl.lisp Log Message: (serve-request): Bind a a slime-toplevel catcher. Handle SLIME-READ-ERRROs. (sldb-loop): Flush output at the beginning. (inspect-in-frame): New function. (frame-locals): Don't send the validity indicator across wire. Too cmucl specific. (sldb-continue, throw-to-toplevel): Moved to swank.lisp Date: Wed Oct 29 18:45:58 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.12 slime/swank-cmucl.lisp:1.13 --- slime/swank-cmucl.lisp:1.12 Fri Oct 24 21:54:00 2003 +++ slime/swank-cmucl.lisp Wed Oct 29 18:45:58 2003 @@ -101,16 +101,14 @@ (defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*) "Read and process a request from a SWANK client. The request is read from the socket as a sexp and then evaluated." - (let ((completed nil)) - (let ((condition (catch 'serve-request-catcher - (read-from-emacs) - (setq completed t)))) - (unless completed - (when *swank-debug-p* - (format *debug-io* - "~&;; Connection to Emacs lost.~%;; [~A]~%" condition)) - (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*)) - (close *emacs-io*))))) + (catch 'slime-toplevel + (with-simple-restart (abort "Return to Slime toplevel.") + (handler-case (read-from-emacs) + (slime-read-error (e) + (when *swank-debug-p* + (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) + (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*)) + (close *emacs-io*)))))) ;;; @@ -590,6 +588,7 @@ (defslimefun sldb-loop () (unix:unix-sigsetmask 0) + (ignore-errors (force-output)) (let* ((*sldb-level* (1+ *sldb-level*)) (*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) (*sldb-restarts* (compute-restarts *swank-debugger-condition*)) @@ -722,6 +721,10 @@ (defslimefun eval-string-in-frame (string index) (to-string (di:eval-in-frame (nth-frame index) (from-string string)))) +(defslimefun inspect-in-frame (string index) + (reset-inspector) + (inspect-object (di:eval-in-frame (nth-frame index) (from-string string)))) + (defslimefun frame-locals (index) (let* ((frame (nth-frame index)) (location (di:frame-code-location frame)) @@ -731,7 +734,6 @@ collect (list :symbol (di:debug-variable-symbol v) :id (di:debug-variable-id v) - :validity (di:debug-variable-validity v location) :value-string (if (eq (di:debug-variable-validity v location) :valid) @@ -745,14 +747,8 @@ (defslimefun invoke-nth-restart (index) (invoke-restart (nth-restart index))) -(defslimefun sldb-continue () - (continue *swank-debugger-condition*)) - (defslimefun sldb-abort () (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) - -(defslimefun throw-to-toplevel () - (throw 'lisp::top-level-catcher nil)) ;;; Inspecting From heller at common-lisp.net Wed Oct 29 23:50:18 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 29 Oct 2003 18:50:18 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8173 Modified Files: swank.lisp Log Message: slime-read-error: New condition. (read-next-form): Re-signal the conditions as slime-read-errors. And check the result of read-sequence (i.e. detect CMUCL's read-sequence bug). (sldb-continue, throw-to-toplevel): Was more or less the same in all backends. Date: Wed Oct 29 18:50:16 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.45 slime/swank.lisp:1.46 --- slime/swank.lisp:1.45 Fri Oct 24 21:54:00 2003 +++ slime/swank.lisp Wed Oct 29 18:50:13 2003 @@ -71,6 +71,11 @@ (apply #'funcall form)) (apply #'funcall form)))) +(define-condition slime-read-error (error) + ((condition :initarg :condition :reader slime-read-error.condition)) + (:report (lambda (condition stream) + (format stream "~A" (slime-read-error.condition condition))))) + (defun read-next-form () "Read the next Slime request from *EMACS-IO* and return an S-expression to be evaluated to handle the request. If an error @@ -81,11 +86,13 @@ (let* ((length (logior (ash (next-byte) 16) (ash (next-byte) 8) (next-byte))) - (string (make-string length))) - (read-sequence string *emacs-io*) + (string (make-string length)) + (pos (read-sequence string *emacs-io*))) + (assert (= pos length) nil + "Short read: length=~D pos=~D" length pos) (read-form string)) - (condition (c) - (throw 'serve-request-catcher c))))) + (serious-condition (c) + (error (make-condition 'slime-read-error :condition c)))))) (defun read-form (string) (with-standard-io-syntax @@ -417,6 +424,15 @@ (defslimefun load-file (filename) (load filename)) + +;;; + +(defslimefun sldb-continue () + (continue *swank-debugger-condition*)) + +(defslimefun throw-to-toplevel () + (throw 'slime-toplevel nil)) + ;;; Local Variables: ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) From heller at common-lisp.net Wed Oct 29 23:53:55 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 29 Oct 2003 18:53:55 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9284 Modified Files: swank-sbcl.lisp Log Message: (serve-request): Bind a slime-toplevel catcher and handle slime-read-errors. (sldb-continue, throw-to-toplevel): Moved to swank.lisp. Date: Wed Oct 29 18:53:55 2003 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.14 slime/swank-sbcl.lisp:1.15 --- slime/swank-sbcl.lisp:1.14 Fri Oct 24 21:54:00 2003 +++ slime/swank-sbcl.lisp Wed Oct 29 18:53:55 2003 @@ -81,19 +81,16 @@ (defun serve-request (*emacs-io*) "Read and process a request from a SWANK client. The request is read from the socket as a sexp and then evaluated." - (let* ((completed nil) - (*slime-output* (make-instance 'slime-output-stream)) - (*slime-input* *standard-input*) - (*slime-io* (make-two-way-stream *slime-input* *slime-output*))) - (let ((condition (catch 'serve-request-catcher - (read-from-emacs) - (setq completed t)))) - (unless completed - (when *swank-debug-p* - (format *debug-io* - "~&;; Connection to Emacs lost.~%;; [~A]~%" condition)) - (sb-sys:invalidate-descriptor (sb-sys:fd-stream-fd *emacs-io*)) - (close *emacs-io*))))) + (catch 'slime-toplevel + (let* ((*slime-output* (make-instance 'slime-output-stream)) + (*slime-input* *standard-input*) + (*slime-io* (make-two-way-stream *slime-input* *slime-output*))) + (handler-case (read-from-emacs) + (slime-read-error (e) + (when *swank-debug-p* + (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) + (sb-sys:invalidate-descriptor (sb-sys:fd-stream-fd *emacs-io*)) + (close *emacs-io*)))))) #| @@ -601,15 +598,8 @@ (defslimefun invoke-nth-restart (index) (invoke-restart (nth-restart index))) -(defslimefun sldb-continue () - (continue *swank-debugger-condition*)) - (defslimefun sldb-abort () (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) - -(defslimefun throw-to-toplevel () - (invoke-restart - (find 'sb-impl::toplevel *sldb-restarts* :key #'restart-name))) ;;; Local Variables: ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) From heller at common-lisp.net Wed Oct 29 23:54:36 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 29 Oct 2003 18:54:36 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9489 Modified Files: swank-openmcl.lisp Log Message: (serve-request): Handle slime-read-errors. (sldb-continue, throw-to-toplevel): Moved to swank.lisp. Date: Wed Oct 29 18:54:36 2003 Author: heller Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.13 slime/swank-openmcl.lisp:1.14 --- slime/swank-openmcl.lisp:1.13 Tue Oct 28 14:11:58 2003 +++ slime/swank-openmcl.lisp Wed Oct 29 18:54:36 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.13 2003/10/28 19:11:58 jbielman Exp $ +;;; $Id: swank-openmcl.lisp,v 1.14 2003/10/29 23:54:36 heller Exp $ ;;; ;;; @@ -84,23 +84,18 @@ "Thread function for a single Swank connection. Processes requests until the remote Emacs goes away." (unwind-protect - (loop - (catch 'slime-toplevel - (with-simple-restart (abort "Return to Slime event loop.") - (let ((completed nil)) - (let* ((*slime-output* (make-instance 'slime-output-stream)) - (*slime-input* *standard-input*) - (*slime-io* (make-two-way-stream *slime-input* - *slime-output*))) - (let ((condition (catch 'serve-request-catcher - (read-from-emacs) - (setq completed t)))) - (unless completed + (let* ((*slime-output* (make-instance 'slime-output-stream)) + (*slime-input* *standard-input*) + (*slime-io* (make-two-way-stream *slime-input* *slime-output*))) + (loop + (catch 'slime-toplevel + (with-simple-restart (abort "Return to Slime event loop.") + (handler-case (read-from-emacs) + (slime-read-error (e) (when *swank-debug-p* (format *debug-io* - "~&;; Connection to Emacs lost.~%;; [~A]~%" - condition)) - (return)))))))) + "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) + (return))))))) (format *terminal-io* "~&;; Swank: Closed connection: ~A~%" *emacs-io*) (close *emacs-io*))) @@ -382,14 +377,8 @@ (let ((restart (nth-restart index))) (invoke-restart restart))) -(defslimefun sldb-continue () - (continue *swank-debugger-condition*)) - (defslimefun sldb-abort () (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) - -(defslimefun throw-to-toplevel () - (throw 'slime-toplevel nil)) ;;; Utilities From heller at common-lisp.net Thu Oct 30 00:01:23 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 29 Oct 2003 19:01:23 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13684 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Oct 29 19:01:21 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.69 slime/ChangeLog:1.70 --- slime/ChangeLog:1.69 Tue Oct 28 23:48:55 2003 +++ slime/ChangeLog Wed Oct 29 19:01:19 2003 @@ -1,3 +1,27 @@ +2003-10-29 Helmut Eller + + * slime.el: + Beginnings of a REPL-mode. + Minor debugger cleanups. + + * swank.lisp: + slime-read-error: New condition. + (read-next-form): Re-signal the conditions as slime-read-errors. And + check the result of read-sequence (i.e. detect CMUCL's read-sequence + bug). + (sldb-continue, throw-to-toplevel): Was more or less the same in all + backends. + + * swank-openmcl.lisp, swank-sbcl.lisp, swank-cmucl.lisp: + (serve-request): Handle slime-read-errors and bind a + slime-toplevel catcher. + + * swank-cmucl.lisp: + (sldb-loop): Flush output at the beginning. + (inspect-in-frame): New function. + (frame-locals): Don't send the validity indicator across wire. Too + cmucl specific. + 2003-10-29 Luke Gorrie * slime.el (slime-net-sentinel): Only show a message about From heller at common-lisp.net Fri Oct 31 16:51:54 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 31 Oct 2003 11:51:54 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19552 Modified Files: slime.el Log Message: (slime-repl-read-mode, slime-repl-read-xxx): New minor mode for stream character based input to Lisp. (slime-read-char-state): Accept :emacs-return-char-code event. (slime-read-input-state): Rename to slime-read-char-state. (slime-activate-state, slime-evaluating-state): Rename the :read-input event to :read-char. (slime-do-eval): Make synchronous RPCs interruptible, even in process-filters and timer-functions. (slime-switch-to-output-buffer): Don't switch the buffer if we are already in the output buffer. Date: Fri Oct 31 11:51:53 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.61 slime/slime.el:1.62 --- slime/slime.el:1.61 Wed Oct 29 18:41:55 2003 +++ slime/slime.el Fri Oct 31 11:51:53 2003 @@ -646,6 +646,8 @@ (slime-swank-port-file))) (setq slime-state-name (format "[polling:%S]" (incf attempt))) (force-mode-line-update) + (when slime-connect-retry-timer + (cancel-timer slime-connect-retry-timer)) (setq slime-connect-retry-timer nil) ; remove old timer (cond ((file-exists-p (slime-swank-port-file)) (let ((port (slime-read-swank-port))) @@ -873,7 +875,7 @@ (slime-idle-state "") (slime-evaluating-state "[eval...]") (slime-debugging-state "[debug]") - (slime-read-input-state "[read]"))) + (slime-read-char-state "[read]"))) (force-mode-line-update) (slime-dispatch-event '(activate)))) @@ -1031,8 +1033,8 @@ ;; To discard the state would break our synchronization. ;; Instead, just cancel the continuation. (setq continuation (lambda (value) t))) - ((:read-input requested tag) - (slime-push-state (slime-read-input-state requested tag)))) + ((:read-char tag) + (slime-push-state (slime-read-char-state tag)))) (slime-defstate slime-debugging-state (level condition restarts depth frames) "Debugging state. @@ -1055,17 +1057,14 @@ (slime-output-evaluate-request form-string package-name) (slime-push-state (slime-evaluating-state continuation)))) -(slime-defstate slime-read-input-state (request tag) +(slime-defstate slime-read-char-state (tag) "Reading state. Lisp waits for input from Emacs." ((activate) - (let (input) - (while (or (not input) - (zerop (length input))) - (slime-show-output-buffer) - (setq input (ignore-errors (read-string "<= ")))) - (slime-net-send `(swank:take-input ,tag ,(concat input "\n"))) - (slime-pop-state)))) + (slime-repl-read-char)) + ((:emacs-return-char-code code) + (slime-net-send `(swank:take-input ,tag ,code)) + (slime-pop-state))) ;;;;; Utilities @@ -1112,8 +1111,10 @@ "Perform an evaluation synchronously. Loops until the result is thrown to our caller, or the user aborts." (slime-eval-string-async (prin1-to-string sexp) package continuation) - (while (slime-busy-p) - (accept-process-output)) + (let ((debug-on-quit t) + (inhibit-quit nil)) + (while (slime-busy-p) + (accept-process-output))) ;; No longer busy, but result not delivered. That means we have ;; entered the debugger. (recursive-edit) @@ -1189,7 +1190,9 @@ (defun slime-switch-to-output-buffer () "Select the output buffer, preferably in a different window." (interactive) - (switch-to-buffer-other-window (slime-output-buffer)) + (set-buffer (slime-output-buffer)) + (unless (eq (current-buffer) (window-buffer)) + (pop-to-buffer (current-buffer) t)) (goto-char (point-max))) (defun slime-show-output-buffer () @@ -1335,6 +1338,10 @@ :end #'1- "No later matching history item")) +(defun slime-repl-read-char () + (slime-switch-to-output-buffer) + (slime-repl-read-mode t)) + (defun slime-repl () (interactive) (slime-switch-to-output-buffer)) @@ -1342,6 +1349,13 @@ (setq slime-repl-mode-map (make-sparse-keymap)) (set-keymap-parent slime-repl-mode-map lisp-mode-map) +(dolist (spec slime-keys) + (destructuring-bind (key command &key inferior prefixed + &allow-other-keys) spec + (when inferior + (let ((key (if prefixed (concat slime-prefix-key key) key))) + (define-key slime-repl-mode-map key command))))) + (slime-define-keys slime-repl-mode-map ("\C-m" 'slime-repl-return) ("\M-p" 'slime-repl-previous-input) @@ -1351,6 +1365,35 @@ ("\t" 'slime-complete-symbol) (" " 'slime-space)) +(defvar slime-repl-read-mode-map) + +(define-minor-mode slime-repl-read-mode + "Mode the read input from Emacs" + nil + nil + ;; Fake binding to coax `define-minor-mode' to create the keymap + '((" " 'slime-repl-read-self-insert-command))) + +(add-to-list 'minor-mode-alist '(slime-repl-read-mode "[read]")) + +(defun slime-char-code (char) + (if (featurep 'xemacs) + (char-int char) + char)) + +(defun slime-repl-read-self-insert-command (char) + (interactive (list last-command-char)) + (insert char) + (slime-dispatch-event `(:emacs-return-char-code ,(slime-char-code char))) + (slime-repl-read-mode nil)) + +(substitute-key-definition + 'self-insert-command 'slime-repl-read-self-insert-command + slime-repl-read-mode-map global-map) + +(slime-define-keys slime-repl-read-mode-map + ("\C-m" (lambda () (interactive) (slime-repl-read-self-insert-command ?\n)))) + ;;; Compilation and the creation of compiler-note annotations From heller at common-lisp.net Fri Oct 31 16:54:32 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 31 Oct 2003 11:54:32 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20139 Modified Files: swank.lisp Log Message: *read-input-catch-tag*, take-input, slime-read-char: Moved here from swank-cmucl.lisp. (defslimefun, defslimefun-unimplemented): Move macro definitions to the beginning of the file. Date: Fri Oct 31 11:54:32 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.46 slime/swank.lisp:1.47 --- slime/swank.lisp:1.46 Wed Oct 29 18:50:13 2003 +++ slime/swank.lisp Fri Oct 31 11:54:31 2003 @@ -28,6 +28,21 @@ (defvar *swank-debug-p* t "When true, print extra debugging information.") +;;; public interface. slimefuns are the things that emacs is allowed +;;; to call + +(defmacro defslimefun (fun &rest rest) + `(progn + (defun ,fun , at rest) + (export ',fun :swank))) + +(defmacro defslimefun-unimplemented (fun args) + `(progn + (defun ,fun ,args + (declare (ignore , at args)) + (error "Backend function ~A not implemented." ',fun)) + (export ',fun :swank))) + ;;; Setup and Hooks (defun start-server (port-file-namestring) @@ -88,7 +103,7 @@ (next-byte))) (string (make-string length)) (pos (read-sequence string *emacs-io*))) - (assert (= pos length) nil + (assert (= pos length) nil "Short read: length=~D pos=~D" length pos) (read-form string)) (serious-condition (c) @@ -143,20 +158,20 @@ (find-package (string-upcase name)))) *package*)) -;;; public interface. slimefuns are the things that emacs is allowed -;;; to call +;;; Input from Emacs -(defmacro defslimefun (fun &rest rest) - `(progn - (defun ,fun , at rest) - (export ',fun :swank))) +(defvar *read-input-catch-tag* 0) -(defmacro defslimefun-unimplemented (fun args) - `(progn - (defun ,fun ,args - (declare (ignore , at args)) - (error "Backend function ~A not implemented." ',fun)) - (export ',fun :swank))) +(defun slime-read-char () + (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*))) + (send-to-emacs `(:read-char ,*read-input-catch-tag*)) + (code-char (catch *read-input-catch-tag* + (loop (read-from-emacs)))))) + +(defslimefun take-input (tag input) + (throw tag input)) + +;;; Evaluation (defvar *swank-debugger-condition*) (defvar *swank-debugger-hook*) From heller at common-lisp.net Fri Oct 31 16:56:54 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 31 Oct 2003 11:56:54 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21744 Modified Files: swank-cmucl.lisp Log Message: (slime-input-stream, slime-input-stream-read-char, slime-input-stream-misc): Character input stream from Emacs. (slime-input-stream/n-bin): Removed. Date: Fri Oct 31 11:56:54 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.13 slime/swank-cmucl.lisp:1.14 --- slime/swank-cmucl.lisp:1.13 Wed Oct 29 18:45:58 2003 +++ slime/swank-cmucl.lisp Fri Oct 31 11:56:52 2003 @@ -44,29 +44,25 @@ (t (lisp::string-out-misc stream operation arg1 arg2)))) (defstruct (slime-input-stream - (:include lisp::lisp-stream - (lisp::n-bin #'slime-input-stream/n-bin) - (lisp::in #'read-char) ; make read-line happy. - (lisp::bin #'read-byte) - (lisp::in-buffer - (make-array lisp::in-buffer-length - :element-type '(unsigned-byte 8))) - (lisp::in-index lisp::in-buffer-length)))) + (:include sys:lisp-stream + (lisp::in #'slime-input-stream-read-char) + (lisp::misc #'slime-input-stream-misc))) + (buffered-char nil :type (or null character))) -(defvar *read-input-catch-tag* 0) +(defun slime-input-stream-read-char (stream &optional eoferr eofval) + (declare (ignore eoferr eofval)) + (let ((c (slime-input-stream-buffered-char stream))) + (cond (c (setf (slime-input-stream-buffered-char stream) nil) c) + (t (slime-read-char))))) -(defun slime-input-stream/n-bin (stream buffer start requested eof-errorp) - (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*))) - (send-to-emacs `(:read-input ,requested ,*read-input-catch-tag*)) - (let ((input (catch *read-input-catch-tag* - (read-from-emacs)))) - (loop for c across input - for i from start - do (setf (aref buffer i) (char-code c))) - (length input)))) - -(defslimefun take-input (tag input) - (throw tag input)) +(defun slime-input-stream-misc (stream operation &optional arg1 arg2) + (declare (ignore arg2)) + (case operation + (:unread + (assert (not (slime-input-stream-buffered-char stream))) + (setf (slime-input-stream-buffered-char stream) arg1) + nil) + (:listen t))) (defun create-swank-server (port &key reuse-address (address "localhost")) "Create a SWANK TCP server." From heller at common-lisp.net Fri Oct 31 16:58:37 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 31 Oct 2003 11:58:37 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21956 Modified Files: swank-sbcl.lisp swank-openmcl.lisp Log Message: Gray stream based input redirection from Emacs. Date: Fri Oct 31 11:58:37 2003 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.15 slime/swank-sbcl.lisp:1.16 --- slime/swank-sbcl.lisp:1.15 Wed Oct 29 18:53:55 2003 +++ slime/swank-sbcl.lisp Fri Oct 31 11:58:37 2003 @@ -68,7 +68,10 @@ "Accept one Swank TCP connection on SOCKET and then close it." (let* ((socket (sb-bsd-sockets:socket-accept server-socket)) (stream (sb-bsd-sockets:socket-make-stream - socket :input t :output t :element-type 'base-char))) + socket :input t :output t :element-type 'base-char)) + (out (make-instance 'slime-output-stream)) + (in (make-instance 'slime-input-stream)) + (io (make-two-way-stream in out))) (sb-sys:invalidate-descriptor (sb-bsd-sockets:socket-file-descriptor server-socket)) (sb-bsd-sockets:socket-close server-socket) @@ -76,22 +79,18 @@ (sb-bsd-sockets:socket-file-descriptor socket) :input (lambda (fd) (declare (ignore fd)) - (serve-request stream))))) + (serve-request stream out in io))))) -(defun serve-request (*emacs-io*) +(defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*) "Read and process a request from a SWANK client. The request is read from the socket as a sexp and then evaluated." (catch 'slime-toplevel - (let* ((*slime-output* (make-instance 'slime-output-stream)) - (*slime-input* *standard-input*) - (*slime-io* (make-two-way-stream *slime-input* *slime-output*))) - (handler-case (read-from-emacs) - (slime-read-error (e) - (when *swank-debug-p* - (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) - (sb-sys:invalidate-descriptor (sb-sys:fd-stream-fd *emacs-io*)) - (close *emacs-io*)))))) - + (handler-case (read-from-emacs) + (slime-read-error (e) + (when *swank-debug-p* + (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) + (sb-sys:invalidate-descriptor (sb-sys:fd-stream-fd *emacs-io*)) + (close *emacs-io*))))) #| @@ -176,6 +175,18 @@ (send-to-emacs `(:read-output ,(get-output-stream-string (slime-output-stream-buffer stream)))) (setf (slime-output-stream-buffer stream) (make-string-output-stream))) + +(defclass slime-input-stream (sb-gray:fundamental-character-input-stream) + ((buffered-char :initform nil))) + +(defmethod sb-gray:stream-read-char ((s slime-input-stream)) + (with-slots (buffered-char) s + (cond (buffered-char (prog1 buffered-char (setf buffered-char nil))) + (t (slime-read-char))))) + +(defmethod sb-gray:stream-unread-char ((s slime-input-stream) char) + (setf (slot-value s 'buffered-char) char) + nil) ;;; Utilities Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.14 slime/swank-openmcl.lisp:1.15 --- slime/swank-openmcl.lisp:1.14 Wed Oct 29 18:54:36 2003 +++ slime/swank-openmcl.lisp Fri Oct 31 11:58:37 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.14 2003/10/29 23:54:36 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.15 2003/10/31 16:58:37 heller Exp $ ;;; ;;; @@ -85,7 +85,7 @@ until the remote Emacs goes away." (unwind-protect (let* ((*slime-output* (make-instance 'slime-output-stream)) - (*slime-input* *standard-input*) + (*slime-input* (make-instance 'slime-input-stream)) (*slime-io* (make-two-way-stream *slime-input* *slime-output*))) (loop (catch 'slime-toplevel @@ -117,6 +117,18 @@ (send-to-emacs `(:read-output ,(get-output-stream-string (slime-output-stream-buffer stream)))) (setf (slime-output-stream-buffer stream) (make-string-output-stream))) + +(defclass slime-input-stream (ccl::fundamental-character-input-stream) + ((buffered-char :initform nil))) + +(defmethod ccl:stream-read-char ((s slime-input-stream)) + (with-slots (buffered-char) s + (cond (buffered-char (prog1 buffered-char (setf buffered-char nil))) + (t (slime-read-char))))) + +(defmethod ccl:stream-unread-char ((s slime-input-stream) char) + (setf (slot-value s 'buffered-char) char) + nil) ;;; Evaluation From heller at common-lisp.net Fri Oct 31 17:06:49 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 31 Oct 2003 12:06:49 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv27467 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Oct 31 12:06:49 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.70 slime/ChangeLog:1.71 --- slime/ChangeLog:1.70 Wed Oct 29 19:01:19 2003 +++ slime/ChangeLog Fri Oct 31 12:06:49 2003 @@ -1,3 +1,20 @@ +2003-10-31 Helmut Eller + + * slime.el: (slime-repl-read-mode, slime-repl-read-xxx): New minor + mode for stream character based input to Lisp. + + * swank.lisp: *read-input-catch-tag*, take-input, slime-read-char: + Moved here from swank-cmucl.lisp. + (defslimefun, defslimefun-unimplemented): Move macro definitions to + the beginning of the file. + + * swank-cmucl.lisp: (slime-input-stream, slime-input-stream-read-char, + lime-input-stream-misc): Character input stream from Emacs. + (slime-input-stream/n-bin): Removed. + + * swank-openmcl.lisp, swank-sbcl.lisp: Gray stream based input + redirection from Emacs. + 2003-10-29 Helmut Eller * slime.el: From lgorrie at common-lisp.net Fri Oct 31 19:25:17 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 31 Oct 2003 14:25:17 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23959 Modified Files: swank.lisp Log Message: (interactive-eval): Evaluate in *buffer-package*. Date: Fri Oct 31 14:25:11 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.47 slime/swank.lisp:1.48 --- slime/swank.lisp:1.47 Fri Oct 31 11:54:31 2003 +++ slime/swank.lisp Fri Oct 31 14:25:06 2003 @@ -193,7 +193,9 @@ (send-to-emacs (if ok `(:ok ,result) '(:aborted))))))) (defslimefun interactive-eval (string) - (let ((values (multiple-value-list (eval (from-string string))))) + (let ((values (multiple-value-list + (let ((*package* *buffer-package*)) + (eval (from-string string)))))) (force-output) (format nil "~{~S~^, ~}" values))) From lgorrie at common-lisp.net Fri Oct 31 19:28:00 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 31 Oct 2003 14:28:00 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv24703 Modified Files: slime.el Log Message: Tweaked debugger window management somewhat: the window configuration is saved when the debugger is first entered and then restored when the idle state is reached. (slime-interrupt, slime-quit): Only send the quit/interrupt message to Lisp if it is in fact evaluating something for us. This fixes a protocol bug reported by Paolo Amoroso. Added (require 'pp). Date: Fri Oct 31 14:27:59 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.62 slime/slime.el:1.63 --- slime/slime.el:1.62 Fri Oct 31 11:51:53 2003 +++ slime/slime.el Fri Oct 31 14:27:59 2003 @@ -54,6 +54,7 @@ (require 'inf-lisp) (require 'cl) +(require 'pp) (require 'hyperspec) (when (featurep 'xemacs) (require 'overlay)) @@ -591,8 +592,8 @@ ;;; Inferior CL Setup: compiling and connecting to Swank -(defvar slime-connect-retry-timer nil - "Timer object for connection retries.") +(defvar slime-startup-retry-timer nil + "Timer object while waiting for an inferior-lisp to start.") (defun slime () "Start an inferior^_superior Lisp and connect to its Swank server." @@ -989,10 +990,16 @@ (defvar slime-stack-eval-tags nil "List of stack-tags of continuations waiting on the stack.") +(defvar sldb-saved-window-configuration nil + "Window configuration before the debugger was entered.") + (slime-defstate slime-idle-state () "Idle state. The only event allowed is to make a request." ((activate) (assert (= sldb-level 0)) + (when sldb-saved-window-configuration + (set-window-configuration sldb-saved-window-configuration) + (setq sldb-saved-window-configuration nil)) (slime-repl-maybe-prompt)) ((:emacs-evaluate form-string package-name continuation) (slime-output-evaluate-request form-string package-name) @@ -1025,6 +1032,8 @@ (when (member tag slime-stack-eval-tags) (throw tag `(:aborted)))))) ((:debug level condition restarts stack-depth frames) + (when (zerop sldb-level) + (setq sldb-saved-window-configuration (current-window-configuration))) (slime-push-state (slime-debugging-state level condition restarts stack-depth frames))) ((:emacs-interrupt) @@ -1136,6 +1145,10 @@ "Return true if Lisp is busy processing a request." (eq (slime-state-name (slime-current-state)) 'slime-evaluating-state)) +(defun slime-evaluating-p () + "Return true if Lisp is evaluating a request for Emacs." + (slime-busy-p)) + (defun slime-idle-p () "Return true if Lisp is idle." (eq (slime-state-name (slime-current-state)) 'slime-idle-state)) @@ -2527,11 +2540,15 @@ (defun slime-interrupt () (interactive) - (slime-dispatch-event '(:emacs-interrupt))) + (if (slime-evaluating-p) + (slime-dispatch-event '(:emacs-interrupt)) + (error "Not evaluating - nothing to interrupt."))) (defun slime-quit () (interactive) - (slime-dispatch-event '(:emacs-quit))) + (if (slime-evaluating-p) + (slime-dispatch-event '(:emacs-quit)) + (error "Not evaluating - nothing to quit."))) (defun slime-set-package (package) (interactive (list (slime-read-package-name "Package: " @@ -2882,8 +2899,11 @@ (defun sldb-cleanup () (let ((sldb-buffer (get-buffer "*sldb*"))) (when sldb-buffer - (delete-windows-on sldb-buffer) - (kill-buffer sldb-buffer)))) + (if (> sldb-level 1) + (with-current-buffer sldb-buffer + (let ((inhibit-read-only t)) + (erase-buffer))) + (kill-buffer sldb-buffer))))) (defun sldb-quit () (interactive) From lgorrie at common-lisp.net Fri Oct 31 19:29:29 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 31 Oct 2003 14:29:29 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26095 Modified Files: ChangeLog Log Message: Date: Fri Oct 31 14:29:29 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.71 slime/ChangeLog:1.72 --- slime/ChangeLog:1.71 Fri Oct 31 12:06:49 2003 +++ slime/ChangeLog Fri Oct 31 14:29:28 2003 @@ -1,3 +1,11 @@ +2003-10-31 Luke Gorrie + + * swank.lisp (interactive-eval): Evaluate in *buffer-package*. + + * slime.el: Tweaked debugger window management somewhat: the + window configuration is saved when the debugger is first entered + and then restored when the idle state is reached. + 2003-10-31 Helmut Eller * slime.el: (slime-repl-read-mode, slime-repl-read-xxx): New minor @@ -43,6 +51,10 @@ * slime.el (slime-net-sentinel): Only show a message about disconnection if the inferior-lisp is still running. + (slime-interrupt, slime-quit): Only send the quit/interrupt + message to Lisp if it is in fact evaluating something for us. This + fixes a protocol bug reported by Paolo Amoroso. Added (require + 'pp). 2003-10-28 James Bielman From lgorrie at common-lisp.net Fri Oct 31 19:35:28 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 31 Oct 2003 14:35:28 -0500 Subject: [slime-cvs] CVS update: slime/slime.el slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28971 Modified Files: slime.el ChangeLog Log Message: (slime-repl-mode-map): Bound `slime-interrupt' on both C-c C-c and C-c C-g. Date: Fri Oct 31 14:35:28 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.63 slime/slime.el:1.64 --- slime/slime.el:1.63 Fri Oct 31 14:27:59 2003 +++ slime/slime.el Fri Oct 31 14:35:28 2003 @@ -1375,6 +1375,8 @@ ("\M-n" 'slime-repl-next-input) ("\M-r" 'slime-repl-previous-matching-input) ("\M-s" 'slime-repl-next-matching-input) + ("\C-c\C-c" 'slime-interrupt) + ("\C-c\C-g" 'slime-interrupt) ("\t" 'slime-complete-symbol) (" " 'slime-space)) Index: slime/ChangeLog diff -u slime/ChangeLog:1.72 slime/ChangeLog:1.73 --- slime/ChangeLog:1.72 Fri Oct 31 14:29:28 2003 +++ slime/ChangeLog Fri Oct 31 14:35:28 2003 @@ -1,5 +1,8 @@ 2003-10-31 Luke Gorrie + * slime.el (slime-repl-mode-map): Bound `slime-interrupt' on both + C-c C-c and C-c C-g. + * swank.lisp (interactive-eval): Evaluate in *buffer-package*. * slime.el: Tweaked debugger window management somewhat: the From lgorrie at common-lisp.net Fri Oct 31 19:53:40 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 31 Oct 2003 14:53:40 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3790 Modified Files: slime.el Log Message: Renamed connection timer to slime-startup-retry-timer. Date: Fri Oct 31 14:53:39 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.64 slime/slime.el:1.65 --- slime/slime.el:1.64 Fri Oct 31 14:35:28 2003 +++ slime/slime.el Fri Oct 31 14:53:39 2003 @@ -647,9 +647,9 @@ (slime-swank-port-file))) (setq slime-state-name (format "[polling:%S]" (incf attempt))) (force-mode-line-update) - (when slime-connect-retry-timer - (cancel-timer slime-connect-retry-timer)) - (setq slime-connect-retry-timer nil) ; remove old timer + (when slime-startup-retry-timer + (cancel-timer slime-startup-retry-timer)) + (setq slime-startup-retry-timer nil) ; remove old timer (cond ((file-exists-p (slime-swank-port-file)) (let ((port (slime-read-swank-port))) (message "Connecting to Swank on port %S.." port) @@ -662,7 +662,7 @@ (message "Failed to connect to Swank.")) (t (when retries (decf retries)) - (setq slime-connect-retry-timer + (setq slime-startup-retry-timer (run-with-timer 1 nil #'attempt-connection)))))) (attempt-connection)))) @@ -672,8 +672,8 @@ (cond ((slime-connected-p) (delete-process slime-net-process) (message "Disconnected.")) - (slime-connect-retry-timer - (cancel-timer slime-connect-retry-timer) + (slime-startup-retry-timer + (cancel-timer slime-startup-retry-timer) (message "Cancelled connection attempt.")) (t (message "Not connected."))))