From mkoeppe at common-lisp.net Sun Sep 4 18:28:58 2005 From: mkoeppe at common-lisp.net (Matthias Koeppe) Date: Sun, 4 Sep 2005 20:28:58 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050904182858.97D108853E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20441 Modified Files: slime.el Log Message: (slime-ensure-presentation-overlay): New. (slime-add-presentation-properties): Don't add face, mouse-face, keymap text properties. Call slime-ensure-presentation-overlay to implement them via overlays. (slime-remove-presentation-properties): Don't remove these text properties. Delete the right overlay. (slime-after-change-function): Add overlays for presentations if necessary. (slime-copy-presentation-at-point): Don't add face text property. (slime-repl-grab-old-output): Likewise. Date: Sun Sep 4 20:28:57 2005 Author: mkoeppe Index: slime/slime.el diff -u slime/slime.el:1.535 slime/slime.el:1.536 --- slime/slime.el:1.535 Wed Aug 31 01:57:26 2005 +++ slime/slime.el Sun Sep 4 20:28:56 2005 @@ -2618,13 +2618,10 @@ (presentation (make-slime-presentation :text text :id id))) (let ((inhibit-modification-hooks t)) (add-text-properties start end - `(face slime-repl-inputed-output-face - mouse-face slime-repl-output-mouseover-face - keymap ,slime-presentation-map - modification-hooks (slime-after-change-function) - insert-in-front-hooks (slime-after-change-function) - insert-behind-hooks (slime-after-change-function) - rear-nonsticky t)) + `(modification-hooks (slime-after-change-function) + insert-in-front-hooks (slime-after-change-function) + insert-behind-hooks (slime-after-change-function) + rear-nonsticky t)) ;; Use the presentation as the key of a text property (case (- end start) (0) @@ -2647,21 +2644,27 @@ ;; when we copy a presentation; their removal is also not undoable. ;; In these cases the mouse-face text properties need to take over --- ;; but they do not give nested highlighting. - (let ((overlay (make-overlay start end))) - (overlay-put overlay 'mouse-face 'slime-repl-output-mouseover-face) - (overlay-put overlay 'face 'slime-repl-inputed-output-face))))) + (slime-ensure-presentation-overlay start end presentation)))) +(defun slime-ensure-presentation-overlay (start end presentation) + (unless (find presentation (overlays-at start) + :key (lambda (overlay) + (overlay-get overlay 'slime-repl-presentation))) + (let ((overlay (make-overlay start end (current-buffer) t nil))) + (overlay-put overlay 'slime-repl-presentation presentation) + (overlay-put overlay 'mouse-face 'slime-repl-output-mouseover-face) + (overlay-put overlay 'face 'slime-repl-inputed-output-face) + (overlay-put overlay 'keymap slime-presentation-map)))) + (defun slime-remove-presentation-properties (from to presentation) (remove-text-properties from to - `(,presentation t - slime-repl-inputed-output-face t - face t mouse-face t rear-nonsticky t)) + `(,presentation t rear-nonsticky t)) (when (eq (get-text-property from 'slime-repl-presentation) presentation) (remove-text-properties from (1+ from) `(slime-repl-presentation t))) (when (eq (get-text-property (1- to) 'slime-repl-presentation) presentation) (remove-text-properties (1- to) to `(slime-repl-presentation t))) (dolist (overlay (overlays-at from)) - (when (eq (overlay-get overlay 'mouse-face) 'slime-repl-output-mouseover-face) + (when (eq (overlay-get overlay 'slime-repl-presentation) presentation) (delete-overlay overlay)))) (defun slime-insert-presentation (result output-id) @@ -2952,20 +2955,23 @@ (defun slime-after-change-function (start end &rest ignore) "Check all presentations within and adjacent to the change. When a presentation has been altered, change it to plain text." - (unless undo-in-progress - (let ((inhibit-modification-hooks t)) - (let ((real-start (max 1 (1- start))) - (real-end (min (1+ (buffer-size)) (1+ end))) - (any-change nil)) - ;; positions around the change - (slime-for-each-presentation-in-region real-start real-end - (lambda (presentation from to whole-p) - (unless whole-p - (slime-remove-presentation-properties from to - presentation) - (setq any-change t)))) - (when any-change - (undo-boundary)))))) + (let ((inhibit-modification-hooks t)) + (let ((real-start (max 1 (1- start))) + (real-end (min (1+ (buffer-size)) (1+ end))) + (any-change nil)) + ;; positions around the change + (slime-for-each-presentation-in-region + real-start real-end + (lambda (presentation from to whole-p) + (cond + (whole-p + (slime-ensure-presentation-overlay from to presentation)) + ((not undo-in-progress) + (slime-remove-presentation-properties from to + presentation) + (setq any-change t))))) + (when any-change + (undo-boundary))))) (defun slime-copy-presentation-at-point (event) (interactive "e") @@ -2981,8 +2987,7 @@ (when (not (string-match "\\s-" (buffer-substring (1- (point)) (point)))) (insert " ")) - (slime-propertize-region '(face slime-repl-inputed-output-face) - (insert (buffer-substring start end))) + (insert (buffer-substring start end)) (when (and (not (eolp)) (not (looking-at "\\s-"))) (insert " ")))) (if (>= (point) slime-repl-prompt-start-mark) @@ -3376,9 +3381,7 @@ (insert " ")))) (delete-region (point) slime-repl-input-end-mark) (let ((inhibit-read-only t)) - (slime-propertize-region - '(face slime-repl-inputed-output-face) - (insert old-output)))))) + (insert old-output))))) (defun slime-property-bounds (prop) "Return two the positions of the previous and next changes to PROP. From mkoeppe at common-lisp.net Sun Sep 4 18:33:08 2005 From: mkoeppe at common-lisp.net (Matthias Koeppe) Date: Sun, 4 Sep 2005 20:33:08 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050904183308.348E98853E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21418 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Sep 4 20:33:07 2005 Author: mkoeppe Index: slime/ChangeLog diff -u slime/ChangeLog:1.766 slime/ChangeLog:1.767 --- slime/ChangeLog:1.766 Wed Aug 31 13:28:08 2005 +++ slime/ChangeLog Sun Sep 4 20:33:07 2005 @@ -1,3 +1,16 @@ +2005-09-04 Matthias Koeppe + + * slime.el (slime-ensure-presentation-overlay): New. + (slime-add-presentation-properties): Don't add face, mouse-face, + keymap text properties. Call slime-ensure-presentation-overlay to + implement them via overlays. + (slime-remove-presentation-properties): Don't remove these text + properties. Delete the right overlay. + (slime-after-change-function): Add overlays for presentations if + necessary. + (slime-copy-presentation-at-point): Don't add face text property. + (slime-repl-grab-old-output): Likewise. + 2005-08-31 Marco Baringer * swank.lisp (to-string): Handle errors during printing of objects. From heller at common-lisp.net Mon Sep 5 13:47:58 2005 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 5 Sep 2005 15:47:58 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050905134758.12469880DB@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4453 Modified Files: slime.el Log Message: (slime-setup-command-hooks): Add after-change-functions only if presentations are enabled. (slime-dispatch-event, slime-enable-evaluate-in-emacs) evaluate-in-emacs): Remove evaluate-in-emacs stuff. It was not used and redundant. (slime-save-some-lisp-buffers): Renamed from save-some-lisp-buffers. (slime-choose-overlay-region): Ignore :source-form locations. (slime-choose-overlay-for-sexp): Ignore errors when stepping over forms. (slime-search-method-location, slime-goto-location-position): Move all this regexpery to it's own function. (slime-recenter-if-needed, slime-repl-return): Factor some duplicated code into its own function. (slime-presentation-bounds, slime-presentation-around-point) (slime-presentation-around-or-before-point): Minor cleanups. Date: Mon Sep 5 15:47:57 2005 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.536 slime/slime.el:1.537 --- slime/slime.el:1.536 Sun Sep 4 20:28:56 2005 +++ slime/slime.el Mon Sep 5 15:47:56 2005 @@ -886,11 +886,8 @@ ;; alanr: need local t (add-hook 'pre-command-hook 'slime-pre-command-hook nil t) (add-hook 'post-command-hook 'slime-post-command-hook nil t) - (add-hook 'after-change-functions 'slime-after-change-function nil t)) - -;(add-hook 'slime-mode-hook 'slime-setup-command-hooks) -;(setq post-command-hook nil) -;(setq pre-command-hook '(completion-before-command tooltip-hide)) + (when slime-repl-enable-presentations + (add-hook 'after-change-functions 'slime-after-change-function nil t))) ;;;; Framework'ey bits @@ -1709,6 +1706,7 @@ (let* ((length (slime-net-decode-length)) (start (+ 6 (point))) (end (+ start length))) + (assert (plusp length)) (let ((string (buffer-substring start end))) (prog1 (read string) (delete-region (point-min) end))))) @@ -2301,7 +2299,7 @@ (slime-send `(:emacs-rex ,form ,package ,thread ,id)))) ((:return value id) (let ((rec (assq id (slime-rex-continuations)))) - (cond (rec (setf (slime-rex-continuations ) + (cond (rec (setf (slime-rex-continuations) (remove rec (slime-rex-continuations))) (when (null (slime-rex-continuations)) (slime-set-state "")) @@ -2327,9 +2325,6 @@ (slime-repl-read-string thread tag)) ((:y-or-n-p thread tag question) (slime-y-or-n-p thread tag question)) - ((:evaluate-in-emacs string thread tag) - (assert thread) - (evaluate-in-emacs (car (read-from-string string)) thread tag)) ((:read-aborted thread tag) (assert thread) (slime-repl-abort-read thread tag)) @@ -2888,7 +2883,7 @@ (values after-end t))) (values point nil)))) -(defun* slime-presentation-bounds (point presentation +(defun* slime-presentation-bounds (point presentation &optional (object (current-buffer))) "Return start index and end index of `presentation' around `point' in `object', and whether the presentation is complete." @@ -2900,10 +2895,11 @@ (and good-start good-end (slime-presentation-whole-p presentation start end object)))))) -(defun* slime-presentation-around-point (point &optional (object (current-buffer))) +(defun slime-presentation-around-point (point &optional object) "Return presentation, start index, end index, and whether the presentation is complete." - (let ((innermost-presentation nil) + (let ((object (or object (current-buffer))) + (innermost-presentation nil) (innermost-start 0) (innermost-end most-positive-fixnum)) (dolist (presentation (slime-presentations-around-point point object)) @@ -2917,12 +2913,13 @@ (values innermost-presentation innermost-start innermost-end))) -(defun* slime-presentation-around-or-before-point (point &optional (object (current-buffer))) - (multiple-value-bind (presentation start end whole-p) - (slime-presentation-around-point point object) - (if presentation - (values presentation start end whole-p) - (slime-presentation-around-point (1- point) object)))) +(defun slime-presentation-around-or-before-point (point &optional object) + (let ((object (or object (current-buffer)))) + (multiple-value-bind (presentation start end whole-p) + (slime-presentation-around-point point object) + (if presentation + (values presentation start end whole-p) + (slime-presentation-around-point (1- point) object))))) (defun* slime-for-each-presentation-in-region (from to function &optional (object (current-buffer))) "Call `function' with arguments `presentation', `start', `end', @@ -3295,17 +3292,11 @@ (cond ((and (get-text-property (point) 'slime-repl-old-input) (< (point) slime-repl-input-start-mark)) (slime-repl-grab-old-input end-of-input) - (unless (pos-visible-in-window-p slime-repl-input-end-mark) - (save-excursion - (goto-char slime-repl-input-end-mark) - (recenter -1)))) + (slime-recenter-if-needed)) ((and (< (point) slime-repl-input-start-mark) - (nth-value 0 (slime-presentation-around-or-before-point (point)))) + (car (slime-presentation-around-or-before-point (point)))) (slime-repl-grab-old-output end-of-input) - (unless (pos-visible-in-window-p slime-repl-input-end-mark) - (save-excursion - (goto-char slime-repl-input-end-mark) - (recenter -1)))) + (slime-recenter-if-needed)) (end-of-input (slime-repl-send-input)) (slime-repl-read-mode ; bad style? @@ -3317,6 +3308,13 @@ (slime-repl-newline-and-indent) (message "[input not complete]")))) +(defun slime-repl-recenter-if-needed () + "Make sure that slime-repl-input-end-mark is visible." + (unless (pos-visible-in-window-p slime-repl-input-end-mark) + (save-excursion + (goto-char slime-repl-input-end-mark) + (recenter -1)))) + (defun slime-repl-send-input (&optional newline) "Goto to the end of the input and send the current input. If NEWLINE is true then add a newline at the end of the input." @@ -3336,7 +3334,6 @@ (overlay-put overlay 'read-only t) (overlay-put overlay 'face 'slime-repl-input-face) (overlay-put overlay 'rear-nonsticky '(face slime-repl-old-input-counter))) - (slime-repl-add-to-input-history (buffer-substring slime-repl-input-start-mark slime-repl-input-end-mark)) @@ -3371,8 +3368,6 @@ output; otherwise the new input is appended." (multiple-value-bind (presentation beg end) (slime-presentation-around-or-before-point (point)) - (unless presentation - (error "No presentation at point")) (let ((old-output (buffer-substring beg end))) ;;keep properties ;; Append the old input or replace the current input (cond (replace (goto-char slime-repl-input-start-mark)) @@ -3636,25 +3631,7 @@ (slime-repl-read-mode 1)) (defun slime-y-or-n-p (thread tag question) - (push thread slime-read-string-threads) - (push tag slime-read-string-tags) - (slime-repl-return-string (y-or-n-p question))) - -(defcustom slime-enable-evaluate-in-emacs nil - "If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs. -The default is nil, as this feature can be a security risk." - :type '(boolean) - :group 'slime-lisp) - -(defun evaluate-in-emacs (expr thread tag) - (cond - (slime-enable-evaluate-in-emacs - (push thread slime-read-string-threads) - (push tag slime-read-string-tags) - (slime-repl-return-string (eval expr))) - (t - (slime-eval-async `(cl:error "Cannot evaluate in Emacs because slime-enable-evaluate-in-emacs is nil")) - nil))) + (slime-dispatch-event `(:emacs-return ,thread ,tag ,(y-or-n-p question)))) (defun slime-repl-return-string (string) (slime-dispatch-event `(:emacs-return-string @@ -3748,7 +3725,7 @@ (insert "\n " (slime-repl-shortcut.one-liner shortcut) "\n")))))) -(defun save-some-lisp-buffers () +(defun slime-save-some-lisp-buffers () (if slime-repl-only-save-lisp-buffers (save-some-buffers nil (lambda () (and (eq major-mode 'lisp-mode) @@ -3841,7 +3818,7 @@ (:handler (lambda (filename) (interactive (list (expand-file-name (read-file-name "File: " nil nil nil nil)))) - (save-some-lisp-buffers) + (slime-save-some-lisp-buffers) (slime-eval-async `(swank:compile-file-if-needed ,(slime-to-lisp-filename filename) t) @@ -4017,7 +3994,7 @@ (or initial-value (slime-find-asd) "")))) (defun slime-oos (system operation &rest keyword-args) - (save-some-lisp-buffers) + (slime-save-some-lisp-buffers) (slime-display-output-buffer) (message "Performing ASDF %S%s on system %S" operation (if keyword-args (format " %S" keyword-args) "") @@ -4505,18 +4482,21 @@ (defun slime-choose-overlay-region (note) "Choose the start and end points for an overlay over NOTE. If the location's sexp is a list spanning multiple lines, then the -region around the first element is used." +region around the first element is used. +Return nil if there's no useful source location." (let ((location (slime-note.location note))) (destructure-case location ((:error msg) ) ; do nothing - ((:location _file pos _hints) - (destructure-case pos - ((:position pos &optional alignp) - (if (eq (slime-note.severity note) :read-error) - (values pos (1+ pos)) - (slime-choose-overlay-for-sexp location))) - (t - (slime-choose-overlay-for-sexp location))))))) + ((:location file pos _hints) + (cond ((eq (car file) ':source-form) nil) + (t + (destructure-case pos + ((:position pos &optional alignp) + (if (eq (slime-note.severity note) :read-error) + (values pos (1+ pos)) + (slime-choose-overlay-for-sexp location))) + (t + (slime-choose-overlay-for-sexp location))))))))) (defun slime-choose-overlay-for-sexp (location) (slime-goto-source-location location) @@ -4527,13 +4507,13 @@ (values start (point)) (values (1+ start) (progn (goto-char (1+ start)) - (or (forward-sexp 1) - (point))))))) + (ignore-errors (forward-sexp 1)) + (point)))))) (defun slime-same-line-p (pos1 pos2) "Return t if buffer positions POS1 and POS2 are on the same line." - (save-excursion (goto-char (min pos1 pos2)) - (<= (max pos1 pos2) (line-end-position)))) + (save-excursion (goto-char (min pos1 pos2)) + (<= (max pos1 pos2) (line-end-position)))) (defun slime-severity-face (severity) "Return the name of the font-lock face representing SEVERITY." @@ -4620,28 +4600,8 @@ ;; FIXME: Isn't this far to general? (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t))) (goto-char (match-beginning 0))) - ;; Looks for a sequence of words (def method name - ;; qualifers specializers don't look for "T" since it isn't - ;; requires (arg without t) as class is taken as such. ((:method name specializers &rest qualifiers) - (let* ((case-fold-search t) - (name (regexp-quote name)) - (qualifiers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>")) - qualifiers "")) - (specializers (mapconcat (lambda (el) - (if (eql (aref el 0) 40) - (let ((spec (read el))) - (if (eq (car spec) 'EQL) - (concat ".*?\\n\\{0,1\\}.*?(EQL.*?'\\{0,1\\}" (format "%s" (second spec)) ")") - (error "don't understand specializer: %s,%s" el (car spec)))) - (concat ".+?\n\\{0,1\\}.+?\\<" el "\\>"))) - (remove "T" specializers) "")) - (regexp (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\s +%s%s" name - qualifiers specializers))) - (or (and (re-search-forward regexp nil t) - (goto-char (match-beginning 0))) - ;; (slime-goto-location-position `(:function-name ,name)) - ))) + (slime-search-method-location name specializers qualifiers)) ((:source-path source-path start-position) (cond (start-position (goto-char start-position) @@ -4655,6 +4615,29 @@ (slime-isearch text) (forward-char delta)))) +(defun slime-search-method-location (name specializers qualifiers) + ;; Look for a sequence of words (def method name + ;; qualifers specializers don't look for "T" since it isn't requires + ;; (arg without t) as class is taken as such. + (let* ((case-fold-search t) + (name (regexp-quote name)) + (qualifiers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>")) + qualifiers "")) + (specializers (mapconcat (lambda (el) + (if (eql (aref el 0) ?\() + (let ((spec (read el))) + (if (eq (car spec) 'EQL) + (concat ".*?\\n\\{0,1\\}.*?(EQL.*?'\\{0,1\\}" (format "%s" (second spec)) ")") + (error "don't understand specializer: %s,%s" el (car spec)))) + (concat ".+?\n\\{0,1\\}.+?\\<" el "\\>"))) + (remove "T" specializers) "")) + (regexp (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\s +%s%s" name + qualifiers specializers))) + (or (and (re-search-forward regexp nil t) + (goto-char (match-beginning 0))) + ;; (slime-goto-location-position `(:function-name ,name)) + ))) + (defun slime-search-call-site (fname) "Move to the place where FNAME called. Don't move if there are multiple or no calls in the current defun." @@ -4667,7 +4650,6 @@ (goto-char (match-beginning 0))) (t (goto-char start)))))) - (defun slime-goto-source-location (location &optional noerror) "Move to the source location LOCATION. Several kinds of locations are supported: @@ -4941,8 +4923,8 @@ (insert arglist)))))) (defun slime-complete-form () - "Complete the form at point. This is a superset of the -functionality of `slime-insert-arglist'." + "Complete the form at point. +This is a superset of the functionality of `slime-insert-arglist'." (interactive) ;; Find the (possibly incomplete) form around point. (let* ((start (save-excursion (backward-up-list 1) (point))) @@ -5857,7 +5839,7 @@ (setq value (apply fun args)) (setq ok t)) (let ((result (if ok `(:ok ,value) `(:abort)))) - (slime-dispatch-event `(:emacs-return ,thread ,tag ,result)))))) + (slime-dispatch-event `(:emacs-return ,thread ,tag ,result) c))))) ;;;; `ED' @@ -5978,8 +5960,9 @@ window)))))) (defun slime-last-expression () - (slime-buffer-substring-with-reified-output (save-excursion (backward-sexp) (point)) - (point))) + (slime-buffer-substring-with-reified-output + (save-excursion (backward-sexp) (point)) + (point))) (defun slime-eval-last-expression () "Evaluate the expression preceding point." @@ -7068,7 +7051,8 @@ (defun sldb-insert-condition (condition) (destructuring-bind (message type references extras) condition (when (> (length message) 70) - (add-text-properties 0 (length message) (list 'help-echo message) message)) + (add-text-properties 0 (length message) (list 'help-echo message) + message)) (slime-insert-propertized '(sldb-default-action sldb-inspect-condition) (in-sldb-face topline message) "\n" @@ -7657,7 +7641,7 @@ (slime-propertize-region `(thread-id ,idx) (insert (format "%3s: " id)) (slime-insert-propertized '(face bold) name) - (insert-char ?\040 (- 30 (current-column))) + (insert-char ?\ (- 30 (current-column))) (let ((summary-start (point))) (insert " " summary) (unless (bolp) (insert "\n")) From heller at common-lisp.net Mon Sep 5 13:54:07 2005 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 5 Sep 2005 15:54:07 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050905135407.2363F880DB@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4511 Modified Files: swank.lisp Log Message: (y-or-n-p-in-emacs): Simplify arglist. (evaluate-in-emacs, dispatch-event, send-to-socket-io): Remove evaluate-in-emacs stuff. (to-string): Undo last change. to-string is not to supposed to ignore errors. Bind *print-readably* instead. (background-message): New function. (symbol-external-p): Simplify it a little. Date: Mon Sep 5 15:54:02 2005 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.329 slime/swank.lisp:1.330 --- slime/swank.lisp:1.329 Wed Aug 31 13:27:47 2005 +++ slime/swank.lisp Mon Sep 5 15:54:02 2005 @@ -333,7 +333,8 @@ "When T swank will attempt to create a second connection to Emacs which is used just to send output.") (defvar *dedicated-output-stream-port* 0 - "Which port we sholud use for the dedicated output stream.") + "Which port we should use for the dedicated output stream.") + (defvar *communication-style* (preferred-communication-style)) (defun start-server (port-file &key (style *communication-style*) @@ -590,9 +591,6 @@ (encode-message `(:read-string ,(thread-id thread) , at args) socket-io)) ((:y-or-n-p thread &rest args) (encode-message `(:y-or-n-p ,(thread-id thread) , at args) socket-io)) - ((:evaluate-in-emacs string thread &rest args) - (encode-message `(:evaluate-in-emacs ,string ,(thread-id thread) , at args) - socket-io)) ((:read-aborted thread &rest args) (encode-message `(:read-aborted ,(thread-id thread) , at args) socket-io)) ((:emacs-return-string thread-id tag string) @@ -721,8 +719,6 @@ ((:return thread &rest args) (declare (ignore thread)) (send `(:return , at args))) - ((:evaluate-in-emacs string thread &rest args) - (send `(:evaluate-in-emacs ,string 0 , at args))) (((:read-output :new-package :new-features :debug-condition :presentation-start :presentation-end :indentation-update :ed :%apply :eval-no-wait @@ -748,19 +744,19 @@ :serve-requests #'spawn-threads-for-connection :cleanup #'cleanup-connection-threads)) (:sigio - (make-connection :socket-io socket-io + (make-connection :socket-io socket-io :read #'read-from-socket-io :send #'send-to-socket-io :serve-requests #'install-sigio-handler :cleanup #'deinstall-sigio-handler)) (:fd-handler - (make-connection :socket-io socket-io + (make-connection :socket-io socket-io :read #'read-from-socket-io :send #'send-to-socket-io :serve-requests #'install-fd-handler :cleanup #'deinstall-fd-handler)) ((nil) - (make-connection :socket-io socket-io + (make-connection :socket-io socket-io :read #'read-from-socket-io :send #'send-to-socket-io :serve-requests #'simple-serve-requests))))) @@ -978,12 +974,12 @@ (defun encode-message (message stream) (let* ((string (prin1-to-string-for-emacs message)) - (length (1+ (length string)))) + (length (length string))) (log-event "WRITE: ~A~%" string) (let ((*print-pretty* nil)) (format stream "~6,'0x" length)) (write-string string stream) - (terpri stream) + ;;(terpri stream) (force-output stream))) (defun prin1-to-string-for-emacs (object) @@ -1019,34 +1015,19 @@ (unless ok (send-to-emacs `(:read-aborted ,(current-thread) ,tag))))))) -(defun y-or-n-p-in-emacs (&optional format-string &rest arguments) +(defun y-or-n-p-in-emacs (format-string &rest arguments) "Like y-or-n-p, but ask in the Emacs minibuffer." (let ((tag (incf *read-input-catch-tag*)) - (question (if format-string - (apply #'format nil format-string arguments) - ""))) + (question (apply #'format nil format-string arguments))) (force-output) (send-to-emacs `(:y-or-n-p ,(current-thread) ,tag ,question)) - (unwind-protect - (catch (intern-catch-tag tag) - (loop (read-from-emacs)))))) + (catch (intern-catch-tag tag) + (loop (read-from-emacs))))) (defslimefun take-input (tag input) "Return the string INPUT to the continuation TAG." (throw (intern-catch-tag tag) input)) -(defun evaluate-in-emacs (string) - (let ((tag (incf *read-input-catch-tag*))) - (force-output) - (send-to-emacs `(:evaluate-in-emacs ,string ,(current-thread) ,tag)) - (let ((ok nil)) - (unwind-protect - (prog1 (catch (intern-catch-tag tag) - (loop (read-from-emacs))) - (setq ok t)) - (unless ok - (send-to-emacs `(:read-aborted ,(current-thread) ,tag))))))) - (defun eval-in-emacs (form &optional nowait) "Eval FORM in Emacs." (destructuring-bind (fun &rest args) form @@ -1115,6 +1096,13 @@ (let ((*readtable* *buffer-readtable*)) (call-with-syntax-hooks fun))))) +(defun to-string (object) + "Write OBJECT in the *BUFFER-PACKAGE*. +The result may not be readable." + (with-buffer-syntax () + (let ((*print-readably* nil)) + (prin1-to-string object)))) + (defun from-string (string) "Read string in the *BUFFER-PACKAGE*" (with-buffer-syntax () @@ -1173,14 +1161,6 @@ (= (length string) pos)) (find-package name)))) -(defun to-string (string) - "Write string in the *BUFFER-PACKAGE*." - (with-buffer-syntax () - (handler-bind ((error (lambda (c) - (declare (ignore c)) - (return-from to-string "#")))) - (prin1-to-string string)))) - (defun guess-package-from-string (name &optional (default-package *package*)) (or (and name (or (parse-package name) @@ -2015,9 +1995,19 @@ "Set the value of a setf'able FORM to VALUE. FORM and VALUE are both strings from Emacs." (with-buffer-syntax () - (eval `(setf ,(read-from-string form) ,(read-from-string (concatenate 'string "`" value)))) + (eval `(setf ,(read-from-string form) + ,(read-from-string (concatenate 'string "`" value)))) t)) +(defun background-message (format-string &rest args) + "Display a message in Emacs' echo area. + +Use this function for informative messages only. The message may even +be dropped, if we are too busy with other things." + (when *emacs-connection* + (send-to-emacs `(:background-message + ,(apply #'format nil format-string args))))) + ;;;; Debugger @@ -2481,14 +2471,10 @@ (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." - (unless package - (setq package (symbol-package symbol))) - (when package - (multiple-value-bind (_ status) - (find-symbol (symbol-name symbol) package) - (declare (ignore _)) - (eq status :external)))) - + (and package + (eq (nth-value 1 (find-symbol (symbol-name symbol) package)) + :external))) + (defun find-matching-packages (name matcher) "Return a list of package names matching NAME with MATCHER. MATCHER is a two-argument predicate." From heller at common-lisp.net Mon Sep 5 13:56:38 2005 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 5 Sep 2005 15:56:38 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: <20050905135638.10D6E880DB@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4572 Modified Files: swank-cmucl.lisp Log Message: (background-message): New function. Forward the call to the front end. (pre-gc-hook, post-gc-hook): Use it. (swank-sym, sending-safe-p): Deleted. Date: Mon Sep 5 15:56:38 2005 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.152 slime/swank-cmucl.lisp:1.153 --- slime/swank-cmucl.lisp:1.152 Mon Aug 29 21:33:26 2005 +++ slime/swank-cmucl.lisp Mon Sep 5 15:56:37 2005 @@ -2061,12 +2061,10 @@ ;;; normal output. ;;; -(defun swank-sym (name) (find-symbol (string name) :swank)) -(defun sending-safe-p () (symbol-value (swank-sym :*emacs-connection*))) - ;; this should probably not be here, but where else? -(defun send-to-emacs (message) - (funcall (swank-sym :send-to-emacs) message)) +(defun background-message (message) + (funcall (find-symbol (string :background-message) :swank) + message)) (defun print-bytes (nbytes &optional stream) "Print the number NBYTES to STREAM in KB, MB, or GB units." @@ -2099,8 +2097,7 @@ (setq *gc-start-time* (get-internal-real-time)) (let ((msg (format nil "[Commencing GC with ~A in use.]" (print-bytes bytes-in-use)))) - (when (sending-safe-p) - (send-to-emacs `(:background-message ,msg))))) + (background-message msg))) (defun post-gc-hook (bytes-retained bytes-freed trigger) (declare (ignore trigger)) @@ -2112,8 +2109,7 @@ #+gencgc(generation-stats) #-gencgc"" seconds))) - (when (sending-safe-p) - (send-to-emacs `(:background-message ,msg))))) + (background-message msg))) (defun install-gc-hooks () (setq ext:*gc-notify-before* #'pre-gc-hook) From heller at common-lisp.net Mon Sep 5 14:00:21 2005 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 5 Sep 2005 16:00:21 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050905140021.98F28880DB@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4638 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Mon Sep 5 16:00:20 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.767 slime/ChangeLog:1.768 --- slime/ChangeLog:1.767 Sun Sep 4 20:33:07 2005 +++ slime/ChangeLog Mon Sep 5 16:00:20 2005 @@ -1,3 +1,35 @@ +2005-09-05 Helmut Eller + + * swank-cmucl.lisp (background-message): New function. Forward the + call to the front end. + (pre-gc-hook, post-gc-hook): Use it. + (swank-sym, sending-safe-p): Deleted. + + * swank.lisp (y-or-n-p-in-emacs): Simplify arglist. + (evaluate-in-emacs, dispatch-event, send-to-socket-io): Remove + evaluate-in-emacs stuff. + (to-string): Undo last change. to-string is not to supposed to + ignore errors. Bind *print-readably* instead. + (background-message): New function. + (symbol-external-p): Simplify it a little. + + * slime.el (slime-setup-command-hooks): Add after-change-functions + only if presentations are enabled. + (slime-dispatch-event, slime-enable-evaluate-in-emacs) + (evaluate-in-emacs): Remove evaluate-in-emacs stuff. It was not + used and redundant. + (slime-save-some-lisp-buffers): Renamed from + save-some-lisp-buffers. + (slime-choose-overlay-region): Ignore :source-form locations. + (slime-choose-overlay-for-sexp): Ignore errors when stepping over + forms. + (slime-search-method-location, slime-goto-location-position): Move + all this regexpery to it's own function. + (slime-recenter-if-needed, slime-repl-return): Factor some + duplicated code into its own function. + (slime-presentation-bounds, slime-presentation-around-point) + (slime-presentation-around-or-before-point): Minor cleanups. + 2005-09-04 Matthias Koeppe * slime.el (slime-ensure-presentation-overlay): New. From mkoeppe at common-lisp.net Wed Sep 7 18:41:38 2005 From: mkoeppe at common-lisp.net (Matthias Koeppe) Date: Wed, 7 Sep 2005 20:41:38 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050907184138.2D3B3880DA@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29167 Modified Files: slime.el Log Message: (slime-menu-choices-for-presentation): New function, return a menu with Inspect/Describe/Copy plus the items that come from the menu protocol. (slime-presentation-menu): Security improvement for the presentation menu protocol: Don't eval arbitrary forms coming from the Lisp. Minor cleanup: Use x-popup-menu in the normal Emacs way, associating a command with each menu item. Date: Wed Sep 7 20:41:34 2005 Author: mkoeppe Index: slime/slime.el diff -u slime/slime.el:1.537 slime/slime.el:1.538 --- slime/slime.el:1.537 Mon Sep 5 15:47:56 2005 +++ slime/slime.el Wed Sep 7 20:41:32 2005 @@ -3006,39 +3006,54 @@ ;; 1. Send lisp message asking for menu choices for this object. Get back list of strings. ;; 2. Let used choose ;; 3. Call back to execute menu choice, passing nth and string of choice -;; 4. Call eval on return value + +(defun slime-menu-choices-for-presentation (presentation from to) + "Return a menu for `presentation' at `from'--`to' in the current +buffer, suitable for `x-popup-menu'." + (let* ((what (slime-presentation-id presentation)) + (choices (slime-eval `(swank::menu-choices-for-presentation-id ',what)))) + (etypecase choices + (list + `(,(if (featurep 'xemacs) " " "") + ("" + ("Inspect" . (lambda () + (interactive) + (slime-inspect-presented-object ',what))) + ("Describe" . (lambda () + (interactive) + (slime-eval '(cl:describe (swank::lookup-presented-object ',what))))) + ("Copy to input" . slime-copy-presentation-at-point) + ,@(let ((nchoice 0)) + (mapcar + (lambda (choice) + (incf nchoice) + (cons choice + `(lambda () + (interactive) + (slime-eval + '(swank::execute-menu-choice-for-presentation-id + ',what ,nchoice ,(nth (1- nchoice) choices)))))) + choices))))) + (symbol ; not-present + (slime-remove-presentation-properties from to presentation) + (sit-for 0) ; allow redisplay + `("Object no longer recorded" + ("sorry" . ,(if (featurep 'xemacs) nil '(nil)))))))) (defun slime-presentation-menu (event) (interactive "e") (let* ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event)))) (window (if (featurep 'xemacs) (event-window event) (caadr event)))) (with-current-buffer (window-buffer window) - (multiple-value-bind (presentation from to whole-p) + (multiple-value-bind (presentation from to) (slime-presentation-around-point point) (unless presentation (error "No presentation at event position")) - (let* ((what (slime-presentation-id presentation)) - (choices (slime-eval `(swank::menu-choices-for-presentation-id ',what))) - (count 0)) - (etypecase choices - (null) - (symbol ; not-present - (slime-remove-presentation-properties from to presentation) - (sit-for 0) ; allow redisplay - (x-popup-menu event `("Object no longer recorded" ("sorry" . ,(if (featurep 'xemacs) nil '(nil)))))) - (list - (let ((choice - (x-popup-menu event - `(,(if (featurep 'xemacs) " " "") - ("" ,@(mapcar - (lambda(choice) - (cons choice (intern choice))) ; use symbol as value to appease xemacs - choices)))))) - (when choice - (let ((nchoice (1+ (position (symbol-name choice) choices :test 'equal)))) - (eval (slime-eval - `(swank::execute-menu-choice-for-presentation-id - ',what ,nchoice ,(nth (1- nchoice) choices)))))))))))))) + (let ((menu (slime-menu-choices-for-presentation + presentation from to))) + (let ((choice (x-popup-menu event menu))) + (when choice + (call-interactively choice)))))))) (defun slime-repl-insert-prompt (result &optional time) From mkoeppe at common-lisp.net Wed Sep 7 18:43:57 2005 From: mkoeppe at common-lisp.net (Matthias Koeppe) Date: Wed, 7 Sep 2005 20:43:57 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/present.lisp Message-ID: <20050907184357.3C364880DA@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29222 Modified Files: present.lisp Log Message: (menu-choices-for-presentation): The Inspect/Describe/Copy items are now provided from the Emacs side. Implement all pathname menu items without having Emacs evaluate a form. Fix for Lisps where ".lisp" is parsed as :name ".lisp". Date: Wed Sep 7 20:43:56 2005 Author: mkoeppe Index: slime/present.lisp diff -u slime/present.lisp:1.13 slime/present.lisp:1.14 --- slime/present.lisp:1.13 Tue Aug 30 15:03:10 2005 +++ slime/present.lisp Wed Sep 7 20:43:55 2005 @@ -164,7 +164,6 @@ ;; You might want append (when (next-method-p) (call-next-method)) to ;; pick up the Menu actions of superclasses. ;; -;; The function should return a form which will be evaluated on the emacs side. (defvar *presentation-active-menu* nil) @@ -196,20 +195,14 @@ ;; Default method (defmethod menu-choices-for-presentation (ob) (declare (ignore ob)) - (list - (list "Inspect" (lambda(choice object id) (declare (ignore choice object)) - `(slime-inspect-presented-object ',id))) - (list "Describe" (lambda(choice object id) (declare (ignore id choice)) - (describe object) - nil)) - (list "Copy to input" (lambda(choice object id) (declare (ignore choice object id)) - `(slime-copy-presentation-at-point event))))) + nil) ;; Pathname (defmethod menu-choices-for-presentation ((ob pathname)) (let* ((file-exists (ignore-errors (probe-file ob))) + (lisp-type (make-pathname :type "lisp")) (source-file (and (not (member (pathname-type ob) '("lisp" "cl") :test 'equal)) - (let ((source (merge-pathnames ".lisp" ob))) + (let ((source (merge-pathnames lisp-type ob))) (and (ignore-errors (probe-file source)) source)))) (fasl-file (and file-exists @@ -217,7 +210,7 @@ (namestring (truename (compile-file-pathname - (merge-pathnames ".lisp" ob))))) + (merge-pathnames lisp-type ob))))) (namestring (truename ob)))))) (remove nil (list* @@ -225,15 +218,17 @@ (list "Edit this file" (lambda(choice object id) (declare (ignore choice id)) - `(find-file ,(namestring (truename object)))))) + (ed-in-emacs (namestring (truename object))) + nil))) (and file-exists (list "Dired containing directory" (lambda (choice object id) (declare (ignore choice id)) - `(dired ,(namestring - (truename - (merge-pathnames - (make-pathname :name "" :type "") object))))))) + (ed-in-emacs (namestring + (truename + (merge-pathnames + (make-pathname :name "" :type "") object)))) + nil))) (and fasl-file (list "Load this fasl file" (lambda (choice object id) @@ -245,14 +240,15 @@ (lambda (choice object id) (declare (ignore choice id object)) (let ((nt (namestring (truename ob)))) - `(when (y-or-n-p ,(format nil "Delete ~a" nt)) - (delete-file ,(namestring (truename ob)))) - )))) + (when (y-or-n-p-in-emacs "Delete ~a? " nt) + (delete-file nt))) + nil))) (and source-file (list "Edit lisp source file" - (lambda(choice object id) + (lambda (choice object id) (declare (ignore choice id object)) - `(find-file ,(namestring (truename source-file)))))) + (ed-in-emacs (namestring (truename source-file))) + nil))) (and source-file (list "Load lisp source file" (lambda(choice object id) From mkoeppe at common-lisp.net Wed Sep 7 18:44:59 2005 From: mkoeppe at common-lisp.net (Matthias Koeppe) Date: Wed, 7 Sep 2005 20:44:59 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050907184459.3446E880DA@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29258 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Sep 7 20:44:59 2005 Author: mkoeppe Index: slime/ChangeLog diff -u slime/ChangeLog:1.768 slime/ChangeLog:1.769 --- slime/ChangeLog:1.768 Mon Sep 5 16:00:20 2005 +++ slime/ChangeLog Wed Sep 7 20:44:51 2005 @@ -1,3 +1,18 @@ +2005-09-07 Matthias Koeppe + + * present.lisp (menu-choices-for-presentation): The + Inspect/Describe/Copy items are now provided from the Emacs side. + Implement all pathname menu items without having Emacs evaluate a + form. Fix for Lisps where ".lisp" is parsed as :name ".lisp". + + * slime.el (slime-menu-choices-for-presentation): New function, + return a menu with Inspect/Describe/Copy plus the items that come + from the menu protocol. + (slime-presentation-menu): Security improvement for the + presentation menu protocol: Don't eval arbitrary forms coming from + the Lisp. Minor cleanup: Use x-popup-menu in the normal Emacs way, + associating a command with each menu item. + 2005-09-05 Helmut Eller * swank-cmucl.lisp (background-message): New function. Forward the From aruttenberg at common-lisp.net Thu Sep 8 23:58:12 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 9 Sep 2005 01:58:12 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/bridge.el slime/ChangeLog Message-ID: <20050908235812.B7FA9880E6@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5900/slime Modified Files: bridge.el ChangeLog Log Message: Date: Fri Sep 9 01:58:11 2005 Author: aruttenberg Index: slime/bridge.el diff -u slime/bridge.el:1.1 slime/bridge.el:1.2 --- slime/bridge.el:1.1 Fri May 20 20:04:12 2005 +++ slime/bridge.el Fri Sep 9 01:58:11 2005 @@ -112,6 +112,9 @@ "The current handler function, if any, that bridge passes strings on to, or nil if none.") +(defvar bridge-leftovers nil + "Because of chunking you might get an incomplete bridge signal - start but the end is in the next packet. Save the overhanging text here.") + (defvar bridge-send-to-buffer nil "The buffer that the default bridge-handler (bridge-send-handler) is currently sending to, or nil if it hasn't started yet. Your handler @@ -233,79 +236,93 @@ bridge-handlers that matches the string. If no handlers match, the input will be sent to bridge-send-handler. If bridge-prompt-regexp is encountered before the bridge-end-regexp, the bridge will be cancelled." - (let ((inhibit-quit t) - (match-data (match-data)) - (buffer (current-buffer)) - (process-buffer (process-buffer process)) - (case-fold-search t) - (start 0) (end 0) - function - b-start b-start-end b-end) - (set-buffer process-buffer) ;; access locals - (setq function bridge-in-progress) - - ;; How it works: - ;; - ;; start, end delimit the part of string we are interested in; - ;; initially both 0; after an iteration we move them to next string. - - ;; b-start, b-end delimit part of string to bridge (possibly whole string); - ;; this will be string between corresponding regexps. - - ;; There are two main cases when we come into loop: - - ;; bridge in progress - ;;0 setq b-start = start - ;;1 setq b-end (or end-pattern end) - ;;4 process string - ;;5 remove handler if end found + (let ((inhibit-quit t) + (match-data (match-data)) + (buffer (current-buffer)) + (process-buffer (process-buffer process)) + (case-fold-search t) + (start 0) (end 0) + function + b-start b-start-end b-end) + (set-buffer process-buffer) ;; access locals + + ;; Handle bridge messages that straddle a packet by prepending + ;; them to this packet. + + (when bridge-leftovers + (setq output (concat bridge-leftovers output)) + (setq bridge-leftovers nil)) + + (setq function bridge-in-progress) + + ;; How it works: + ;; + ;; start, end delimit the part of string we are interested in; + ;; initially both 0; after an iteration we move them to next string. + + ;; b-start, b-end delimit part of string to bridge (possibly whole string); + ;; this will be string between corresponding regexps. + + ;; There are two main cases when we come into loop: + + ;; bridge in progress + ;;0 setq b-start = start + ;;1 setq b-end (or end-pattern end) + ;;4 process string + ;;5 remove handler if end found - ;; no bridge in progress - ;;0 setq b-start if see start-pattern - ;;1 setq b-end if bstart to (or end-pattern end) - ;;2 send (substring start b-start) to normal place - ;;3 find handler (in b-start, b-end) if not set - ;;4 process string - ;;5 remove handler if end found - - ;; equivalent sections have the same numbers here; - ;; we fold them together in this code. - - (unwind-protect - (while (< end (length output)) - - ;;0 setq b-start if find - (setq b-start - (cond (bridge-in-progress - (setq b-start-end start) - start) - ((string-match bridge-start-regexp output start) - (setq b-start-end (match-end 0)) - (match-beginning 0)) - (t nil))) - ;;1 setq b-end - (setq b-end - (if b-start - (let ((end-seen (string-match bridge-end-regexp - output b-start-end))) - (if end-seen (setq end (match-end 0))) - end-seen))) - (if (not b-end) (setq end (length output) - b-end (length output))) - - ;;1.5 - if see prompt before end, remove current - (if b-start - (let ((prompt (string-match bridge-prompt-regexp - output b-start-end))) - (if (and prompt (<= (match-end 0) b-end)) - (setq b-start nil ; b-start-end start - b-end start - end (match-end 0) - bridge-in-progress nil - )))) + ;; no bridge in progress + ;;0 setq b-start if see start-pattern + ;;1 setq b-end if bstart to (or end-pattern end) + ;;2 send (substring start b-start) to normal place + ;;3 find handler (in b-start, b-end) if not set + ;;4 process string + ;;5 remove handler if end found + + ;; equivalent sections have the same numbers here; + ;; we fold them together in this code. + + (block bridge-filter + (unwind-protect + (while (< end (length output)) + + ;;0 setq b-start if find + (setq b-start + (cond (bridge-in-progress + (setq b-start-end start) + start) + ((string-match bridge-start-regexp output start) + (setq b-start-end (match-end 0)) + (match-beginning 0)) + (t nil))) + ;;1 setq b-end + (setq b-end + (if b-start + (let ((end-seen (string-match bridge-end-regexp + output b-start-end))) + (if end-seen (setq end (match-end 0))) + + end-seen))) + + ;; Detect and save partial bridge messages + (when (and b-start b-start-end (not b-end)) + (setq bridge-leftovers (substring output b-start)) + ) + (if (not b-end) (setq end b-start)) + + ;;1.5 - if see prompt before end, remove current + (if (and b-start b-end) + (let ((prompt (string-match bridge-prompt-regexp + output b-start-end))) + (if (and prompt (<= (match-end 0) b-end)) + (setq b-start nil ; b-start-end start + b-end start + end (match-end 0) + bridge-in-progress nil + )))) - ;;2 send (substring start b-start) to old filter, if any - (if (/= start (or b-start end)) ; don't bother on empty string + ;;2 send (substring start b-start) to old filter, if any + (when (not (equal start (or b-start end))) ; don't bother on empty string (let ((pass-on (substring output start (or b-start end)))) (if bridge-old-filter (let ((old bridge-old-filter)) @@ -316,50 +333,54 @@ (if (not (eq new 'bridge-filter)) (progn (setq bridge-old-filter new) (set-process-filter process 'bridge-filter))))) - (set-buffer process-buffer) - (bridge-insert pass-on)))) + (set-buffer process-buffer) + (bridge-insert pass-on)))) - ;;3 find handler (in b-start, b-end) if none current - (if (and b-start (not bridge-in-progress)) - (let ((handlers bridge-handlers)) - (while (and handlers (not function)) - (let* ((handler (car handlers)) - (m (string-match (car handler) output b-start-end))) - (if (and m (< m b-end)) - (setq function (cdr handler)) - (setq handlers (cdr handlers))))) - ;; Set default handler if none - (if (null function) - (setq function 'bridge-send-handler)) - (setq bridge-in-progress function))) - ;;4 process string - (if function - (let ((ok t)) - (if (/= b-start-end b-end) - (let ((send (substring output b-start-end b-end))) - ;; also, insert the stuff in buffer between - ;; iff bridge-source-insert. - (if bridge-source-insert (bridge-insert send)) - ;; call handler on string - (setq ok (bridge-call-handler function process send)))) - ;;5 remove handler if end found - ;; if function removed then tell it that's all - (if (or (not ok) (/= b-end end));; saw end before end-of-string - (progn - (bridge-call-handler function process nil) - ;; have to remove function too for next time around - (setq function nil - bridge-in-progress nil) + (if (and b-start-end (not b-end)) + (return-from bridge-filter t) ; when last bit has prematurely ending message, exit early. + (progn + ;;3 find handler (in b-start, b-end) if none current + (if (and b-start (not bridge-in-progress)) + (let ((handlers bridge-handlers)) + (while (and handlers (not function)) + (let* ((handler (car handlers)) + (m (string-match (car handler) output b-start-end))) + (if (and m (< m b-end)) + (setq function (cdr handler)) + (setq handlers (cdr handlers))))) + ;; Set default handler if none + (if (null function) + (setq function 'bridge-send-handler)) + (setq bridge-in-progress function))) + ;;4 process strin + (if function + (let ((ok t)) + (if (/= b-start-end b-end) + (let ((send (substring output b-start-end b-end))) + ;; also, insert the stuff in buffer between + ;; iff bridge-source-insert. + (if bridge-source-insert (bridge-insert send)) + ;; call handler on string + (setq ok (bridge-call-handler function process send)))) + ;;5 remove handler if end found + ;; if function removed then tell it that's all + (if (or (not ok) (/= b-end end)) ;; saw end before end-of-string + (progn + (bridge-call-handler function process nil) + ;; have to remove function too for next time around + (setq function nil + bridge-in-progress nil) + )) )) - )) - ;; continue looping, in case there's more string - (setq start end) - )) - ;; protected forms: restore buffer, match-data - (set-buffer buffer) - (store-match-data match-data) - )) + ;; continue looping, in case there's more string + (setq start end)) + )) + ;; protected forms: restore buffer, match-data + (set-buffer buffer) + (store-match-data match-data) + )))) + ;;;%Interface (defun install-bridge () @@ -378,6 +399,7 @@ (make-local-variable 'bridge-string) (make-local-variable 'bridge-in-progress) (make-local-variable 'bridge-send-to-buffer) + (make-local-variable 'bridge-leftovers) (setq bridge-string nil bridge-in-progress nil bridge-send-to-buffer nil) (if (boundp 'comint-prompt-regexp) Index: slime/ChangeLog diff -u slime/ChangeLog:1.769 slime/ChangeLog:1.770 --- slime/ChangeLog:1.769 Wed Sep 7 20:44:51 2005 +++ slime/ChangeLog Fri Sep 9 01:58:11 2005 @@ -1,3 +1,14 @@ +2005-09-08 Alan Ruttenberg + + * bridge.el Fix bug in bridge filter where a bridge message which + straddled a packet would be mishandled. Sometimes this would + result in spurious bridge message text being inserted with the + presentation and the presentation not being sensitive. In other + cases there would be an actual error. Introduce bridge-leftovers + to save the last, unfinished bit for the next call, and prepend it + before processing a chuunk. Also, fix the parentheses so that the + unwind protect cleanup forms are actually in the cleanup section. + 2005-09-07 Matthias Koeppe * present.lisp (menu-choices-for-presentation): The From aruttenberg at common-lisp.net Fri Sep 9 00:10:59 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 9 Sep 2005 02:10:59 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050909001059.07BED880E6@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6982/slime Modified Files: ChangeLog Log Message: Date: Fri Sep 9 02:10:59 2005 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.770 slime/ChangeLog:1.771 --- slime/ChangeLog:1.770 Fri Sep 9 01:58:11 2005 +++ slime/ChangeLog Fri Sep 9 02:10:59 2005 @@ -8,6 +8,10 @@ to save the last, unfinished bit for the next call, and prepend it before processing a chuunk. Also, fix the parentheses so that the unwind protect cleanup forms are actually in the cleanup section. + In openmcl, where apparently communication with slime is done in + 2k chunks, you can trigger the bug with something like this: + (swank::presenting-object 'foo t + (dotimes (i 2040) (write-char #\:))) 2005-09-07 Matthias Koeppe From aruttenberg at common-lisp.net Fri Sep 9 01:43:12 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 9 Sep 2005 03:43:12 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/bridge.el Message-ID: <20050909014312.7C8A6880E6@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12997/slime Modified Files: bridge.el Log Message: Date: Fri Sep 9 03:43:11 2005 Author: aruttenberg Index: slime/bridge.el diff -u slime/bridge.el:1.2 slime/bridge.el:1.3 --- slime/bridge.el:1.2 Fri Sep 9 01:58:11 2005 +++ slime/bridge.el Fri Sep 9 03:43:11 2005 @@ -308,7 +308,11 @@ (when (and b-start b-start-end (not b-end)) (setq bridge-leftovers (substring output b-start)) ) - (if (not b-end) (setq end b-start)) + + (if (and b-start (not b-end)) + (setq end b-start) + (if (not b-end) + (setq end (length output)))) ;;1.5 - if see prompt before end, remove current (if (and b-start b-end) From aruttenberg at common-lisp.net Fri Sep 9 02:01:15 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 9 Sep 2005 04:01:15 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp slime/ChangeLog Message-ID: <20050909020115.00548880E6@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14764/slime Modified Files: swank-openmcl.lisp ChangeLog Log Message: Date: Fri Sep 9 04:01:14 2005 Author: aruttenberg Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.98 slime/swank-openmcl.lisp:1.99 --- slime/swank-openmcl.lisp:1.98 Sun Aug 28 16:48:47 2005 +++ slime/swank-openmcl.lisp Fri Sep 9 04:01:10 2005 @@ -253,16 +253,17 @@ (make-location (list :buffer *buffer-name*) (list :position position t)) - (make-location - (list :file (ccl::compiler-warning-file-name condition)) - (list :position position t))))))) + (if (ccl::compiler-warning-file-name condition) + (make-location + (list :file (namestring (truename (ccl::compiler-warning-file-name condition)))) + (list :position position t)))))))) (defun temp-file-name () "Return a temporary file name to compile strings into." (ccl:%get-cstring (#_tmpnam (ccl:%null-ptr)))) (defimplementation call-with-compilation-hooks (function) - (handler-bind ((ccl::compiler-warning #'handle-compiler-warning)) + (handler-bind ((ccl::compiler-warning 'handle-compiler-warning)) (funcall function))) (defimplementation swank-compile-file (filename load-p Index: slime/ChangeLog diff -u slime/ChangeLog:1.771 slime/ChangeLog:1.772 --- slime/ChangeLog:1.771 Fri Sep 9 02:10:59 2005 +++ slime/ChangeLog Fri Sep 9 04:01:13 2005 @@ -13,6 +13,11 @@ (swank::presenting-object 'foo t (dotimes (i 2040) (write-char #\:))) + * swank-openmcl.lisp (handle-compiler-warning). Don't create a + location if the condition doesn't have a filename. If it does, + make sure you pass a string rather than a pathname object + otherwise you get a net-read error + 2005-09-07 Matthias Koeppe * present.lisp (menu-choices-for-presentation): The From aruttenberg at common-lisp.net Fri Sep 9 17:10:21 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 9 Sep 2005 19:10:21 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog slime/slime.el Message-ID: <20050909171021.626D78854B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12847/slime Modified Files: ChangeLog slime.el Log Message: Date: Fri Sep 9 19:10:20 2005 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.772 slime/ChangeLog:1.773 --- slime/ChangeLog:1.772 Fri Sep 9 04:01:13 2005 +++ slime/ChangeLog Fri Sep 9 19:10:18 2005 @@ -1,3 +1,7 @@ +2005-09-09 Alan Ruttenberg + * slime.el (slime-choose-overlay-region). Don't try to overlay a + note if location is nil. + 2005-09-08 Alan Ruttenberg * bridge.el Fix bug in bridge filter where a bridge message which Index: slime/slime.el diff -u slime/slime.el:1.538 slime/slime.el:1.539 --- slime/slime.el:1.538 Wed Sep 7 20:41:32 2005 +++ slime/slime.el Fri Sep 9 19:10:18 2005 @@ -4500,18 +4500,19 @@ region around the first element is used. Return nil if there's no useful source location." (let ((location (slime-note.location note))) - (destructure-case location - ((:error msg) ) ; do nothing - ((:location file pos _hints) - (cond ((eq (car file) ':source-form) nil) - (t - (destructure-case pos - ((:position pos &optional alignp) - (if (eq (slime-note.severity note) :read-error) - (values pos (1+ pos)) - (slime-choose-overlay-for-sexp location))) - (t - (slime-choose-overlay-for-sexp location))))))))) + (when location + (destructure-case location + ((:error msg) ) ; do nothing + ((:location file pos _hints) + (cond ((eq (car file) ':source-form) nil) + (t + (destructure-case pos + ((:position pos &optional alignp) + (if (eq (slime-note.severity note) :read-error) + (values pos (1+ pos)) + (slime-choose-overlay-for-sexp location))) + (t + (slime-choose-overlay-for-sexp location)))))))))) (defun slime-choose-overlay-for-sexp (location) (slime-goto-source-location location) From mkoeppe at common-lisp.net Sat Sep 10 18:27:46 2005 From: mkoeppe at common-lisp.net (Matthias Koeppe) Date: Sat, 10 Sep 2005 20:27:46 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050910182746.0D3F488537@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23789 Modified Files: slime.el Log Message: (slime-enable-evaluate-in-emacs): Resurrected. (slime-dispatch-event): Respect slime-enable-evaluate-in-emacs for messages :eval-no-wait and :eval. Date: Sat Sep 10 20:27:42 2005 Author: mkoeppe Index: slime/slime.el diff -u slime/slime.el:1.539 slime/slime.el:1.540 --- slime/slime.el:1.539 Fri Sep 9 19:10:18 2005 +++ slime/slime.el Sat Sep 10 20:27:42 2005 @@ -2280,6 +2280,12 @@ This variable is rebound by the :RETURN event handler and used by slime-repl-insert-prompt.") +(defcustom slime-enable-evaluate-in-emacs nil + "If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs. +The default is nil, as this feature can be a security risk." + :type '(boolean) + :group 'slime-lisp) + (defun slime-dispatch-event (event &optional process) (let ((slime-dispatching-connection (or process (slime-connection)))) (destructure-case event @@ -2341,9 +2347,13 @@ ((:open-dedicated-output-stream port) (slime-open-stream-to-lisp port)) ((:eval-no-wait fun args) - (apply (intern fun) args)) + (if slime-enable-evaluate-in-emacs + (apply (intern fun) args) + (error "Cannot evaluate in Emacs because slime-enable-evaluate-in-emacs is nil"))) ((:eval thread tag fun args) - (slime-eval-for-lisp thread tag (intern fun) args)) + (if slime-enable-evaluate-in-emacs + (slime-eval-for-lisp thread tag (intern fun) args) + (slime-eval-async `(cl:error "Cannot evaluate in Emacs because slime-enable-evaluate-in-emacs is nil")))) ((:emacs-return thread tag value) (slime-send `(:emacs-return ,thread ,tag ,value))) ((:ed what) From mkoeppe at common-lisp.net Sat Sep 10 18:28:33 2005 From: mkoeppe at common-lisp.net (Matthias Koeppe) Date: Sat, 10 Sep 2005 20:28:33 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050910182833.A29CE88537@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23821 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Sep 10 20:28:33 2005 Author: mkoeppe Index: slime/ChangeLog diff -u slime/ChangeLog:1.773 slime/ChangeLog:1.774 --- slime/ChangeLog:1.773 Fri Sep 9 19:10:18 2005 +++ slime/ChangeLog Sat Sep 10 20:28:32 2005 @@ -1,3 +1,9 @@ +2005-09-10 Matthias Koeppe + + * slime.el (slime-enable-evaluate-in-emacs): Resurrected. + (slime-dispatch-event): Respect slime-enable-evaluate-in-emacs for + messages :eval-no-wait and :eval. + 2005-09-09 Alan Ruttenberg * slime.el (slime-choose-overlay-region). Don't try to overlay a note if location is nil. From heller at common-lisp.net Mon Sep 12 22:42:55 2005 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Sep 2005 00:42:55 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050912224255.E054F8855C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15219 Modified Files: swank.lisp Log Message: Simplify the object <-> presentation-id mapping. (save-presented-object): Remove the optional `id' arg. (lookup-presented-object): Id's should be fixnums not some cons with fuzzy/non-documented meaning. Use the secondary return value to test for absence of the id. Update callers accordingly. (*not-present*): Deleted. Remove the repl result special cases, let the general presentation machinery handle it. (*last-repl-result-id*, add-repl-result, *current-id*) (clear-last-repl-result): Deleted. (listener-eval): Don't *current-id* to tag result values. (*can-print-presentation*): Deleted. Nobody quite knows whether it's still needed so let just try without it. Updated referrers accordingly. (eval-region, run-repl-eval-hooks): Move the eval hook stuff to a separate function. Date: Tue Sep 13 00:42:54 2005 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.330 slime/swank.lisp:1.331 --- slime/swank.lisp:1.330 Mon Sep 5 15:54:02 2005 +++ slime/swank.lisp Tue Sep 13 00:42:54 2005 @@ -220,7 +220,8 @@ ;; The coding system for network streams. (external-format *coding-system* :type (member :iso-latin-1-unix :emacs-mule-unix - :utf-8-unix))) + :utf-8-unix + :euc-jp-unix))) (defun print-connection (conn stream depth) (declare (ignore depth)) @@ -1686,7 +1687,7 @@ "Store the mapping of objects to numeric identifiers") (defvar *presentation-id-to-object* - (make-weak-value-hash-table :test 'eq) + (make-weak-value-hash-table :test 'eql) "Store the mapping of numeric identifiers to objects") (defun clear-presentation-tables () @@ -1695,50 +1696,26 @@ (defvar *presentation-counter* 0 "identifier counter") -(defun save-presented-object (object &optional id) - "If the object doesn't already have an id, save it and allocate -one. Otherwise return the old one." - (cond - ((and (not id) - (gethash object *object-to-presentation-id*))) - (t - (let ((newid (or id (decf *presentation-counter*)))) - (setf (gethash newid *presentation-id-to-object*) object) - (setf (gethash object *object-to-presentation-id*) newid) - newid)))) - -(defvar *not-present* (gensym "NOT-PRESENT")) +;; XXX thread safety? +(defun save-presented-object (object) + "Save OBJECT and return the assigned id. +If OBJECT was saved previously return the old id." + (or (gethash object *object-to-presentation-id*) + (let ((id (decf *presentation-counter*))) + (setf (gethash id *presentation-id-to-object*) object) + (setf (gethash object *object-to-presentation-id*) id) + id))) (defun lookup-presented-object (id) - "Retrieve the object corresponding to id. *not-present* returned if it isn't there" - (if (consp id) - (let ((values (gethash (car id) *presentation-id-to-object* *not-present*))) - (if (eql values *not-present*) - *not-present* - (nth (cdr id) values))) - (gethash id *presentation-id-to-object* *not-present*))) - -(defvar *last-repl-result-id* nil) - -(defun add-repl-result (id val) - (save-presented-object val id) - (setq *last-repl-result-id* id) - t) + "Retrieve the object corresponding to ID. +The secondary value indicates the a absence of an entry." + (gethash id *presentation-id-to-object*)) (defslimefun get-repl-result (id) "Get the result of the previous REPL evaluation with ID." - (let ((previous-output (lookup-presented-object id))) - (when (eq previous-output *not-present*) - (if swank::*record-repl-results* - (error "Attempt to access no longer existing result (number ~D)." id) - (error "Attempt to access unrecorded result (number ~D). ~&See ~S." - id '*record-repl-results*))) - previous-output)) - -(defslimefun clear-last-repl-result () - "Forget the result of the previous REPL evaluation." - (remhash *last-repl-result-id* *presentation-id-to-object*) - t) + (multiple-value-bind (object foundp) (lookup-presented-object id) + (cond (foundp object) + (t (error "Attempt to access unrecorded object (id ~D)." id))))) (defslimefun clear-repl-results () "Forget the results of all previous REPL evaluations." @@ -1757,11 +1734,6 @@ (or (guess-package-from-string string nil) *package*)) -(defvar *current-id* nil) - -(defvar *can-print-presentation* nil - "set this to t in contexts where it is ok to print presentations at all") - (defun eval-for-emacs (form buffer-package id) "Bind *BUFFER-PACKAGE* BUFFER-PACKAGE and evaluate FORM. Return the result to the continuation ID. @@ -1773,8 +1745,7 @@ (unwind-protect (let ((*buffer-package* (guess-buffer-package buffer-package)) (*buffer-readtable* (guess-buffer-readtable buffer-package)) - (*pending-continuations* (cons id *pending-continuations*)) - (*current-id* id)) + (*pending-continuations* (cons id *pending-continuations*))) (check-type *buffer-package* package) (check-type *buffer-readtable* readtable) (setq result (eval form)) @@ -1796,12 +1767,11 @@ (t (format nil "~{~S~^, ~}" values)))))) (defslimefun interactive-eval (string) - (let ((*can-print-presentation* t)) - (with-buffer-syntax () - (let ((values (multiple-value-list (eval (from-string string))))) - (fresh-line) - (force-output) - (format-values-for-echo-area values))))) + (with-buffer-syntax () + (let ((values (multiple-value-list (eval (from-string string))))) + (fresh-line) + (force-output) + (format-values-for-echo-area values))))) (defslimefun eval-and-grab-output (string) (with-buffer-syntax () @@ -1811,6 +1781,7 @@ (list (get-output-stream-string s) (format nil "~{~S~^~%~}" values))))) +;;; XXX do we need this stuff? What is it good for? (defvar *slime-repl-advance-history* nil "In the dynamic scope of a single form typed at the repl, is set to nil to prevent the repl from advancing the history - * ** *** etc.") @@ -1857,20 +1828,23 @@ (return (values values -))) (setq - form) (if *slime-repl-eval-hooks* - (loop for hook in *slime-repl-eval-hooks* - for res = (catch *slime-repl-eval-hook-pass* (multiple-value-list (funcall hook form))) - until (not (eq res *slime-repl-eval-hook-pass*)) - finally - (if (eq res *slime-repl-eval-hook-pass*) - (setq values (multiple-value-list (eval form))) - (setq values res))) - (setq values (multiple-value-list (eval form)))) + (setq values (run-repl-eval-hooks form)) + (setq values (multiple-value-list (eval form)))) (force-output))))) (when (and package-update-p (not (eq *package* *buffer-package*))) (send-to-emacs (list :new-package (package-name *package*) (package-string-for-prompt *package*)))))) +(defun run-repl-eval-hooks (form) + (loop for hook in *slime-repl-eval-hooks* + for res = (catch *slime-repl-eval-hook-pass* + (multiple-value-list (funcall hook form))) + until (not (eq res *slime-repl-eval-hook-pass*)) + finally (if (eq res *slime-repl-eval-hook-pass*) + (setq values (multiple-value-list (eval form))) + (setq values res)))) + (defun package-string-for-prompt (package) "Return the shortest nickname (or canonical name) of PACKAGE." (or (canonical-package-nickname package) @@ -1946,21 +1920,19 @@ (with-buffer-syntax () (let ((*slime-repl-suppress-output* :unset) (*slime-repl-advance-history* :unset)) - (multiple-value-bind (values last-form) - (let ((*can-print-presentation* t)) - (eval-region string t)) + (multiple-value-bind (values last-form) (eval-region string t) (unless (or (and (eq values nil) (eq last-form nil)) (eq *slime-repl-advance-history* nil)) (setq *** ** ** * * (car values) - /// // // / / values) - (when *record-repl-results* - (add-repl-result *current-id* values))) + /// // // / / values)) (setq +++ ++ ++ + + last-form) - (if (eq *slime-repl-suppress-output* t) - "" - (cond ((null values) "; No value") - (t - (mapcar #'prin1-to-string values)))))))) + (cond ((eq *slime-repl-suppress-output* t) '(:suppress-output)) + (*record-repl-results* + `(:present ,(loop for x in values + collect (cons (prin1-to-string x) + (save-presented-object x))))) + (t + `(:values (mapcar #'prin1-to-string values)))))))) (defslimefun ed-in-emacs (&optional what) "Edit WHAT in Emacs. @@ -2131,13 +2103,9 @@ (defslimefun backtrace (start end) "Return a list ((I FRAME) ...) of frames from START to END. I is an integer describing and FRAME a string." - (let ((*can-print-presentation* nil)) - ;; Disable presentations during backtrack, for now. For one thing, - ;; the filter isn't set up for the sldb buffer. Also there is - ;; higher likelyhood of lossage due to dynamic extent objects. - (loop for frame in (compute-backtrace start end) - for i from start - collect (list i (frame-for-emacs i frame))))) + (loop for frame in (compute-backtrace start end) + for i from start + collect (list i (frame-for-emacs i frame)))) (defslimefun debugger-info-for-emacs (start end) "Return debugger state, with stack frames from START to END. @@ -2288,23 +2256,21 @@ (if s (list :short-message s))))) (defun swank-compiler (function) - (let ((*can-print-presentation* t)) - (clear-compiler-notes) - (with-simple-restart (abort "Abort SLIME compilation.") - (multiple-value-bind (result usecs) - (handler-bind ((compiler-condition #'record-note-for-condition)) - (measure-time-interval function)) - (list (to-string result) - (format nil "~,2F" (/ usecs 1000000.0))))))) + (clear-compiler-notes) + (with-simple-restart (abort "Abort SLIME compilation.") + (multiple-value-bind (result usecs) + (handler-bind ((compiler-condition #'record-note-for-condition)) + (measure-time-interval function)) + (list (to-string result) + (format nil "~,2F" (/ usecs 1000000.0)))))) (defslimefun compile-file-for-emacs (filename load-p &optional external-format) "Compile FILENAME and, when LOAD-P, load the result. Record compiler notes signalled as `compiler-condition's." - (let ((*can-print-presentation* t)) - (with-buffer-syntax () - (let ((*compile-print* nil)) - (swank-compiler (lambda () (swank-compile-file filename load-p - external-format))))))) + (with-buffer-syntax () + (let ((*compile-print* nil)) + (swank-compiler (lambda () (swank-compile-file filename load-p + external-format)))))) (defslimefun compile-string-for-emacs (string buffer position directory) "Compile STRING (exerpted from BUFFER at POSITION). @@ -2362,8 +2328,7 @@ ;;;; Loading (defslimefun load-file (filename) - (let ((*can-print-presentation* t)) - (to-string (load filename)))) + (to-string (load filename))) (defslimefun load-file-set-package (filename &optional package) (load-file filename) @@ -3868,11 +3833,9 @@ *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))) (defslimefun init-inspector (string) - (let ((*can-print-presentation* nil)) - ;; Disable presentations. - (with-buffer-syntax () - (reset-inspector) - (inspect-object (eval (read-from-string string)))))) + (with-buffer-syntax () + (reset-inspector) + (inspect-object (eval (read-from-string string))))) (defun print-part-to-string (value) (let ((string (to-string value)) From heller at common-lisp.net Mon Sep 12 22:57:02 2005 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Sep 2005 00:57:02 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050912225702.261208855C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16626 Modified Files: slime.el Log Message: (slime-current-output-id): Remove this ugly kludge. (slime-repl-insert-result): New function. Handle the presentations and other special cases cleaner. (slime-repl-insert-prompt): Use it. The `result' arg is now a structured list; update callers accordingly. (slime-repl-return): Make the prefix arg work again. (package-updating): The result of swank::listener-eval changed a bit. Update the test. Remove some unnecessary uses of `defun*' and reindent it to 80 columns. Date: Tue Sep 13 00:57:01 2005 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.540 slime/slime.el:1.541 --- slime/slime.el:1.540 Sat Sep 10 20:27:42 2005 +++ slime/slime.el Tue Sep 13 00:57:00 2005 @@ -1,4 +1,4 @@ -;;; -*- mode: emacs-lisp; mode: outline-minor; outline-regexp: ";;;;+"; indent-tabs-mode: nil -*- +;;; -*- outline-regexp: ";;;;+"; indent-tabs-mode: nil -*- ;; slime.el -- Superior Lisp Interaction Mode for Emacs ;;;; License ;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller @@ -1552,7 +1552,8 @@ (iso-8859-1-unix nil :iso-latin-1-unix) (binary nil :iso-latin-1-unix) (utf-8-unix t :utf-8-unix) - (emacs-mule-unix t :emacs-mule-unix)) + (emacs-mule-unix t :emacs-mule-unix) + (euc-jp-unix t :euc-jp-unix)) "A list of valid coding systems. Each element is of the form: (NAME MULTIBYTEP CL-NAME)") @@ -2274,12 +2275,6 @@ (slime-def-connection-var slime-continuation-counter 0 "Continuation serial number counter.") -(defvar slime-current-output-id nil - "The id of the current repl output. - -This variable is rebound by the :RETURN event handler and used by -slime-repl-insert-prompt.") - (defcustom slime-enable-evaluate-in-emacs nil "If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs. The default is nil, as this feature can be a security risk." @@ -2309,9 +2304,7 @@ (remove rec (slime-rex-continuations))) (when (null (slime-rex-continuations)) (slime-set-state "")) - (let ((slime-current-output-id id)) ;; this is not very - ;; elegant but it avoids changing the protocol - (funcall (cdr rec) value))) + (funcall (cdr rec) value)) (t (error "Unexpected reply: %S %S" id value))))) ((:debug-activate thread level) @@ -2465,7 +2458,8 @@ (slime-repl-mode) (setq slime-buffer-connection connection) (slime-reset-repl-markers) - (unless noprompt (slime-repl-insert-prompt "" 0)) + (unless noprompt + (slime-repl-insert-prompt '(:suppress-output) 0)) (current-buffer))))) (defun slime-repl-update-banner () @@ -2487,7 +2481,8 @@ (animate-string (format "; SLIME %s" (or (slime-changelog-date) "- ChangeLog file not found")) 0 0)) - (slime-repl-insert-prompt (if use-header-p "" (concat "; " banner))))) + (slime-repl-insert-prompt + `(:values (,(if use-header-p "" (concat "; " banner))))))) (defun slime-changelog-date () "Return the datestring of the latest entry in the ChangeLog file. @@ -2612,9 +2607,7 @@ (id (car (read-from-string match)))) (slime-mark-presentation-end id)))) -(defstruct (slime-presentation) - (text) - (id)) +(defstruct slime-presentation text id) (defun slime-add-presentation-properties (start end id result-p) "Make the text between START and END a presentation with ID. @@ -2829,38 +2822,42 @@ (slime-setup-command-hooks) (run-hooks 'slime-repl-mode-hook)) -(defun* slime-presentation-whole-p (presentation start end &optional (object (current-buffer))) - (string= (etypecase object - (buffer (with-current-buffer object - (buffer-substring-no-properties start end))) - (string (substring-no-properties object start end))) - (slime-presentation-text presentation))) - -(defun* slime-presentations-around-point (point &optional (object (current-buffer))) - (loop for (key value . rest) on (text-properties-at point object) by 'cddr - when (slime-presentation-p key) - collect key)) +(defun slime-presentation-whole-p (presentation start end &optional object) + (let ((object (or object (current-buffer)))) + (string= (etypecase object + (buffer (with-current-buffer object + (buffer-substring-no-properties start end))) + (string (substring-no-properties object start end))) + (slime-presentation-text presentation)))) + +(defun slime-presentations-around-point (point &optional object) + (let ((object (or object (current-buffer)))) + (loop for (key value . rest) on (text-properties-at point object) by 'cddr + when (slime-presentation-p key) + collect key))) (defun slime-presentation-start-p (tag) - (member tag '(:start :start-and-end))) + (memq tag '(:start :start-and-end))) (defun slime-presentation-stop-p (tag) - (member tag '(:end :start-and-end))) + (memq tag '(:end :start-and-end))) (defun* slime-presentation-start (point presentation &optional (object (current-buffer))) - "Find start of `presentation' at `point' in `object'. Return buffer index and - whether a start-tag was found." + "Find start of `presentation' at `point' in `object'. +Return buffer index and whether a start-tag was found." (let* ((this-presentation (get-text-property point presentation object))) (while (not (slime-presentation-start-p this-presentation)) - (let ((change-point (previous-single-property-change point presentation object))) + (let ((change-point (previous-single-property-change + point presentation object))) (unless change-point (return-from slime-presentation-start (values (etypecase object (buffer (with-current-buffer object 1)) (string 0)) nil))) - (setq this-presentation (get-text-property change-point presentation object)) + (setq this-presentation (get-text-property change-point + presentation object)) (unless this-presentation (return-from slime-presentation-start (values point nil))) @@ -2874,7 +2871,8 @@ end-tag was found." (let* ((this-presentation (get-text-property point presentation object))) (while (not (slime-presentation-stop-p this-presentation)) - (let ((change-point (next-single-property-change point presentation object))) + (let ((change-point (next-single-property-change + point presentation object))) (unless change-point (return-from slime-presentation-end (values (etypecase object @@ -2882,9 +2880,11 @@ (string (length object))) nil))) (setq point change-point) - (setq this-presentation (get-text-property point presentation object)))) + (setq this-presentation (get-text-property point + presentation object)))) (if this-presentation - (let ((after-end (next-single-property-change point presentation object))) + (let ((after-end (next-single-property-change point + presentation object))) (if (not after-end) (values (etypecase object (buffer (with-current-buffer object (point-max))) @@ -2903,7 +2903,8 @@ (slime-presentation-end point presentation object) (values start end (and good-start good-end - (slime-presentation-whole-p presentation start end object)))))) + (slime-presentation-whole-p presentation + start end object)))))) (defun slime-presentation-around-point (point &optional object) "Return presentation, start index, end index, and whether the @@ -2960,8 +2961,8 @@ (let ((undo-in-progress t)) ad-do-it))) (defun slime-after-change-function (start end &rest ignore) - "Check all presentations within and adjacent to the change. When a - presentation has been altered, change it to plain text." + "Check all presentations within and adjacent to the change. +When a presentation has been altered, change it to plain text." (let ((inhibit-modification-hooks t)) (let ((real-start (max 1 (1- start))) (real-end (min (1+ (buffer-size)) (1+ end))) @@ -3013,7 +3014,8 @@ (define-key slime-presentation-map [button3] 'slime-presentation-menu)) ;; protocol for handling up a menu. -;; 1. Send lisp message asking for menu choices for this object. Get back list of strings. +;; 1. Send lisp message asking for menu choices for this object. +;; Get back list of strings. ;; 2. Let used choose ;; 3. Call back to execute menu choice, passing nth and string of choice @@ -3021,7 +3023,8 @@ "Return a menu for `presentation' at `from'--`to' in the current buffer, suitable for `x-popup-menu'." (let* ((what (slime-presentation-id presentation)) - (choices (slime-eval `(swank::menu-choices-for-presentation-id ',what)))) + (choices (slime-eval + `(swank::menu-choices-for-presentation-id ',what)))) (etypecase choices (list `(,(if (featurep 'xemacs) " " "") @@ -3029,9 +3032,12 @@ ("Inspect" . (lambda () (interactive) (slime-inspect-presented-object ',what))) - ("Describe" . (lambda () - (interactive) - (slime-eval '(cl:describe (swank::lookup-presented-object ',what))))) + ("Describe" . + (lambda () + (interactive) + ;; XXX remove call to describe. + (slime-eval '(cl:describe + (swank::lookup-presented-object ',what))))) ("Copy to input" . slime-copy-presentation-at-point) ,@(let ((nchoice 0)) (mapcar @@ -3065,42 +3071,24 @@ (when choice (call-interactively choice)))))))) - (defun slime-repl-insert-prompt (result &optional time) - "Goto to point max, insert RESULT and the prompt. Set -slime-output-end to start of the inserted text slime-input-start to -end end. If RESULT is not a string, it must be a list of -result strings, each of which is marked-up as a presentation." + "Goto to point max, insert RESULT and the prompt. +Set slime-output-end to start of the inserted text slime-input-start +to end end." (slime-flush-output) (goto-char (point-max)) (let ((start (point))) (unless (bolp) (insert "\n")) - (flet ((insert-result (result id) - (if (and slime-repl-enable-presentations id) - (slime-insert-presentation result id) - (slime-propertize-region `(face slime-repl-result-face) - (insert result))) - (unless (bolp) (insert "\n")))) - (etypecase result - (list - (loop - for res in result - for index from 0 - do (insert-result res (cons slime-current-output-id index)))) - (string - (unless (string= result "") - (insert-result result nil))))) + (slime-repl-insert-result result) (let ((prompt-start (point)) (prompt (format "%s> " (slime-lisp-package-prompt-string)))) (slime-propertize-region - '(face slime-repl-prompt-face - read-only t - intangible t - slime-repl-prompt t - ;; emacs stuff - rear-nonsticky (slime-repl-prompt read-only face intangible) - ;; xemacs stuff - start-open t end-open t) + '(face slime-repl-prompt-face read-only t intangible t + slime-repl-prompt t + ;; emacs stuff + rear-nonsticky (slime-repl-prompt read-only face intangible) + ;; xemacs stuff + start-open t end-open t) (insert prompt)) ;; FIXME: we could also set beginning-of-defun-function (setq defun-prompt-regexp (concat "^" prompt)) @@ -3115,6 +3103,25 @@ (current-buffer))))))) (slime-repl-show-maximum-output)) +(defun slime-repl-insert-result (result) + "Insert the result of an evaluation. +RESULT can be one of: + (:values (STRING...)) + (:present ((STRING . ID)...)) + (:suppress-output)" + (destructure-case result + ((:values strings) + (cond ((null strings) (insert "; No value\n")) + (t (dolist (s strings) + (insert s "\n"))))) + ((:present stuff) + (cond ((and stuff slime-repl-enable-presentations) + (loop for (s . id) in stuff do + (slime-insert-presentation s id) + (insert "\n"))) + (t (slime-repl-insert-result `(:values ,(mapcar #'car stuff)))))) + ((:suppress-output)))) + (defun slime-repl-move-output-mark-before-prompt (buffer) (when (buffer-live-p buffer) (with-current-buffer buffer @@ -3208,8 +3215,10 @@ (insert-before-markers "; Evaluation aborted\n")) (slime-rex () ((list 'swank:listener-eval "") nil) - ((:ok result) (with-current-buffer (slime-output-buffer) - (slime-repl-insert-prompt "")))))) + ((:ok result) + ;; A hack to get the prompt + (with-current-buffer (slime-output-buffer) + (slime-repl-insert-prompt '(:suppress-output))))))) (defun slime-mark-input-start () (set-marker slime-repl-last-input-start-mark @@ -3314,18 +3323,17 @@ (interactive "P") (slime-check-connected) (assert (<= (point) slime-repl-input-end-mark)) - (cond ((and (get-text-property (point) 'slime-repl-old-input) - (< (point) slime-repl-input-start-mark)) - (slime-repl-grab-old-input end-of-input) - (slime-recenter-if-needed)) - ((and (< (point) slime-repl-input-start-mark) - (car (slime-presentation-around-or-before-point (point)))) - (slime-repl-grab-old-output end-of-input) - (slime-recenter-if-needed)) - (end-of-input + (cond (end-of-input (slime-repl-send-input)) (slime-repl-read-mode ; bad style? (slime-repl-send-input t)) + ((and (get-text-property (point) 'slime-repl-old-input) + (< (point) slime-repl-input-start-mark)) + (slime-repl-grab-old-input end-of-input) + (slime-repl-recenter-if-needed)) + ((car (slime-presentation-around-or-before-point (point))) + (slime-repl-grab-old-output end-of-input) + (slime-repl-recenter-if-needed)) ((slime-input-complete-p slime-repl-input-start-mark slime-repl-input-end-mark) (slime-repl-send-input t)) @@ -3477,7 +3485,6 @@ (defun slime-repl-clear-output () "Delete the output inserted since the last input." (interactive) - (slime-eval `(swank::clear-last-repl-result)) (let ((start (save-excursion (slime-repl-previous-prompt) (ignore-errors (forward-sexp)) @@ -3501,7 +3508,7 @@ (slime-eval `(swank:set-package ,package)) (setf (slime-lisp-package) name) (setf (slime-lisp-package-prompt-string) prompt-string) - (slime-repl-insert-prompt "" 0) + (slime-repl-insert-prompt '(:suppress-output) 0) (insert unfinished-input))))) @@ -9003,8 +9010,6 @@ "(cl:setq cl:*package* (cl:find-package %S)) (cl:package-name cl:*package*)" package-name)) (slime-lisp-package)))) - (slime-check ("In %s package." package-name) - (equal (format "\"%s\"" package-name) p)) (slime-check ("slime-lisp-package is %S." package-name) (equal (slime-lisp-package) package-name)) (slime-check ("slime-lisp-package-prompt-string is in %S." nicknames) From heller at common-lisp.net Mon Sep 12 22:58:18 2005 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Sep 2005 00:58:18 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp slime/swank-sbcl.lisp Message-ID: <20050912225818.1B7848855C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16734 Modified Files: swank-clisp.lisp swank-sbcl.lisp Log Message: Add EUC-JP as coding system. This patch eliminates the requirement of Mule-UCS to use Japanese characters. (Nice for pre-22 Emacs users.) Patch from NIIMI Satoshi. Date: Tue Sep 13 00:58:17 2005 Author: heller Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.54 slime/swank-clisp.lisp:1.55 --- slime/swank-clisp.lisp:1.54 Mon Aug 22 06:30:30 2005 +++ slime/swank-clisp.lisp Tue Sep 13 00:58:17 2005 @@ -122,6 +122,8 @@ (:iso-latin-1-unix (ext:make-encoding :charset 'charset:iso-8859-1 :line-terminator :unix)) (:utf-8-unix (ext:make-encoding :charset 'charset:utf-8 + :line-terminator :unix)) + (:euc-jp-unix (ext:make-encoding :charset 'charset:euc-jp :line-terminator :unix)))) (defimplementation accept-connection (socket Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.143 slime/swank-sbcl.lisp:1.144 --- slime/swank-sbcl.lisp:1.143 Mon Aug 29 13:23:55 2005 +++ slime/swank-sbcl.lisp Tue Sep 13 00:58:17 2005 @@ -122,8 +122,8 @@ (defun find-external-format (coding-system) (ecase coding-system (:iso-latin-1-unix :iso-8859-1) - #+sb-unicode - (:utf-8-unix :utf-8))) + (:utf-8-unix :utf-8) + (:euc-jp-unix :euc-jp))) (defun make-socket-io-stream (socket external-format) (let ((ef (find-external-format external-format))) From heller at common-lisp.net Mon Sep 12 22:59:04 2005 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Sep 2005 00:59:04 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-loader.lisp Message-ID: <20050912225904.D238D8855C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16828 Modified Files: swank-loader.lisp Log Message: (lisp-version-string)[cmu]: Replace spaces with underscores. Date: Tue Sep 13 00:59:04 2005 Author: heller Index: slime/swank-loader.lisp diff -u slime/swank-loader.lisp:1.51 slime/swank-loader.lisp:1.52 --- slime/swank-loader.lisp:1.51 Wed Aug 3 11:40:20 2005 +++ slime/swank-loader.lisp Tue Sep 13 00:59:04 2005 @@ -9,9 +9,9 @@ ;;; (cl:defpackage :swank-loader - (:use :common-lisp)) + (:use :cl)) -(in-package :swank-loader) +(cl:in-package :swank-loader) (defun make-swank-pathname (name &optional (type "lisp")) "Return a pathname with name component NAME in the Slime directory." @@ -38,7 +38,8 @@ ))) (defparameter *implementation-features* - '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp :armedbear :gcl :ecl)) + '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp + :armedbear :gcl :ecl)) (defparameter *os-features* '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :unix)) @@ -47,10 +48,10 @@ '(:powerpc :ppc :x86 :x86-64 :i686 :pc386 :iapx386 :sparc)) (defun lisp-version-string () - #+cmu (substitute #\- #\/ (lisp-implementation-version)) + #+cmu (substitute-if #\_ (lambda (x) (find x " /")) + (lisp-implementation-version)) #+sbcl (lisp-implementation-version) #+ecl (lisp-implementation-version) - #+gcl (let ((s (lisp-implementation-version))) (subseq s 4)) #+openmcl (format nil "~d.~d" ccl::*openmcl-major-version* ccl::*openmcl-minor-version*) @@ -133,25 +134,23 @@ (load file :verbose t) (force-output))) -(compile-files-if-needed-serially - (append (list (make-swank-pathname "swank-backend")) - *sysdep-pathnames* - (list *swank-pathname*))) - -(funcall (intern (string :warn-unimplemented-interfaces) :swank-backend)) - (defun load-user-init-file () "Load the user init file, return NIL if it does not exist." (load (merge-pathnames (user-homedir-pathname) (make-pathname :name ".swank" :type "lisp")) :if-does-not-exist nil)) -(export 'load-user-init-file) (defun load-site-init-file () (load (make-pathname :name "site-init" :type "lisp" :defaults *load-truename*) :if-does-not-exist nil)) -(or (load-site-init-file) - (load-user-init-file)) +(compile-files-if-needed-serially + (append (list (make-swank-pathname "swank-backend")) + *sysdep-pathnames* + (list *swank-pathname*))) + +(funcall (intern (string :warn-unimplemented-interfaces) :swank-backend)) +(load-site-init-file) +(load-user-init-file) From heller at common-lisp.net Mon Sep 12 23:06:44 2005 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Sep 2005 01:06:44 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050912230644.6FA4D8855C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18149 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Sep 13 01:06:43 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.774 slime/ChangeLog:1.775 --- slime/ChangeLog:1.774 Sat Sep 10 20:28:32 2005 +++ slime/ChangeLog Tue Sep 13 01:06:43 2005 @@ -1,3 +1,53 @@ +2005-09-13 Helmut Eller + + * present.lisp (menu-choices-for-presentation-id): Use + lookup-presented-object secondary return value instead of + *not-present*. + (execute-menu-choice-for-presentation-id, presenting-object-1): + Remove references to *can-print-presentation*. + + * slime.el (slime-current-output-id): Remove this ugly klugde. + (slime-repl-insert-result): New function. Handle the presentations + and other special cases cleaner. + (slime-repl-insert-prompt): Use it. The `result' arg is now a + structured list; update callers accordingly. + (slime-repl-return): Make the prefix arg work again. + (package-updating): The result of swank::listener-eval changed a + bit. Update the test. + + Remove some unnecessary uses of `defun*' and reindent it to 80 + columns. + + * swank.lisp: Simplify the object <-> presentation-id mapping. + (save-presented-object): Remove the optional `id' arg. + (lookup-presented-object): Id's should be fixnums not some cons + with fuzzy/non-documented meaning. Use the secondary return value + to test for absence of the id. Update callers accordingly. + (*not-present*): Deleted. + + Remove the repl result special cases, let the general presentation + machinery handle it. + (*last-repl-result-id*, add-repl-result, *current-id*) + (clear-last-repl-result): Deleted. + (listener-eval): Don't *current-id* to tag result values. + + (*can-print-presentation*): Deleted. Nobody quite knows whether + it's still needed so let just try without it. Updated referrers + accordingly. + + (eval-region, run-repl-eval-hooks): Move the eval hook stuff to + a separate function. + + * swank-loader.lisp (lisp-version-string)[cmu]: Replace spaces + with underscores. + +2005-09-12 NIIMI Satoshi + + * swank.lisp, slime.el, swank-clisp.lisp, swank-sbcl.lisp: add + EUC-JP as coding system. This patch eliminates the requirement of + Mule-UCS to use Japanese characters. (Nice for pre-22 Emacs + users.) + 2005-09-10 Matthias Koeppe * slime.el (slime-enable-evaluate-in-emacs): Resurrected. @@ -69,7 +119,7 @@ (slime-choose-overlay-for-sexp): Ignore errors when stepping over forms. (slime-search-method-location, slime-goto-location-position): Move - all this regexpery to it's own function. + all this regexpery to its own function. (slime-recenter-if-needed, slime-repl-return): Factor some duplicated code into its own function. (slime-presentation-bounds, slime-presentation-around-point) @@ -121,6 +171,7 @@ (slime-y-or-n-p): New. 2005-08-29 Alan Ruttenberg + * slime.el (sldb-insert-condition) - Add tooltip for long condition string which otherwise falls off the right of the screen * swank.lisp (list-threads) - thread name might be a symbol - pass From heller at common-lisp.net Mon Sep 12 23:07:22 2005 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Sep 2005 01:07:22 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/present.lisp Message-ID: <20050912230722.6691F8855C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18234 Modified Files: present.lisp Log Message: (menu-choices-for-presentation-id): Use lookup-presented-object secondary return value instead of *not-present*. (execute-menu-choice-for-presentation-id, presenting-object-1): Remove references to *can-print-presentation*. Date: Tue Sep 13 01:07:21 2005 Author: heller Index: slime/present.lisp diff -u slime/present.lisp:1.14 slime/present.lisp:1.15 --- slime/present.lisp:1.14 Wed Sep 7 20:43:55 2005 +++ slime/present.lisp Tue Sep 13 01:07:21 2005 @@ -135,8 +135,7 @@ (defun presenting-object-1 (object stream continue) "Uses the bridge mechanism with two messages >id and Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19988 Modified Files: swank.lisp Log Message: Fix parens. Date: Tue Sep 13 01:29:42 2005 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.331 slime/swank.lisp:1.332 --- slime/swank.lisp:1.331 Tue Sep 13 00:42:54 2005 +++ slime/swank.lisp Tue Sep 13 01:29:41 2005 @@ -1771,7 +1771,7 @@ (let ((values (multiple-value-list (eval (from-string string))))) (fresh-line) (force-output) - (format-values-for-echo-area values))))) + (format-values-for-echo-area values)))) (defslimefun eval-and-grab-output (string) (with-buffer-syntax () @@ -1842,8 +1842,8 @@ (multiple-value-list (funcall hook form))) until (not (eq res *slime-repl-eval-hook-pass*)) finally (if (eq res *slime-repl-eval-hook-pass*) - (setq values (multiple-value-list (eval form))) - (setq values res)))) + (multiple-value-list (eval form)) + res))) (defun package-string-for-prompt (package) "Return the shortest nickname (or canonical name) of PACKAGE." From heller at common-lisp.net Tue Sep 13 00:11:59 2005 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Sep 2005 02:11:59 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050913001159.CC9FA8855C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23126 Modified Files: slime.el Log Message: (slime-repl-insert-result): Add slime-repl-result-face face. (slime-repl-update-banner): Avoid insert extra newlines. Date: Tue Sep 13 02:11:59 2005 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.541 slime/slime.el:1.542 --- slime/slime.el:1.541 Tue Sep 13 00:57:00 2005 +++ slime/slime.el Tue Sep 13 02:11:56 2005 @@ -2481,8 +2481,8 @@ (animate-string (format "; SLIME %s" (or (slime-changelog-date) "- ChangeLog file not found")) 0 0)) - (slime-repl-insert-prompt - `(:values (,(if use-header-p "" (concat "; " banner))))))) + (slime-repl-insert-prompt (cond (use-header-p `(:suppress-output)) + (t `(:values (,(concat "; " banner)))))))) (defun slime-changelog-date () "Return the datestring of the latest entry in the ChangeLog file. @@ -3113,7 +3113,8 @@ ((:values strings) (cond ((null strings) (insert "; No value\n")) (t (dolist (s strings) - (insert s "\n"))))) + (slime-insert-propertized `(face slime-repl-result-face) s) + (insert "\n"))))) ((:present stuff) (cond ((and stuff slime-repl-enable-presentations) (loop for (s . id) in stuff do From aruttenberg at common-lisp.net Tue Sep 13 04:15:09 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Tue, 13 Sep 2005 06:15:09 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog slime/swank.lisp slime/slime.el Message-ID: <20050913041509.D5DA88855C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7257/slime Modified Files: ChangeLog swank.lisp slime.el Log Message: Date: Tue Sep 13 06:14:54 2005 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.775 slime/ChangeLog:1.776 --- slime/ChangeLog:1.775 Tue Sep 13 01:06:43 2005 +++ slime/ChangeLog Tue Sep 13 06:14:53 2005 @@ -1,3 +1,7 @@ +2005-09-13 Alan Ruttenberg + * slime.el (defcustom slime-ed-use-dedicated-frame ... vs defvar + * swank.lisp (run-repl-eval-hooks .. finally (return vs no return + 2005-09-13 Helmut Eller * present.lisp (menu-choices-for-presentation-id): Use Index: slime/swank.lisp diff -u slime/swank.lisp:1.332 slime/swank.lisp:1.333 --- slime/swank.lisp:1.332 Tue Sep 13 01:29:41 2005 +++ slime/swank.lisp Tue Sep 13 06:14:53 2005 @@ -1830,6 +1830,7 @@ (if *slime-repl-eval-hooks* (setq values (run-repl-eval-hooks form)) (setq values (multiple-value-list (eval form)))) + (ccl::print-db values) (force-output))))) (when (and package-update-p (not (eq *package* *buffer-package*))) (send-to-emacs @@ -1838,12 +1839,13 @@ (defun run-repl-eval-hooks (form) (loop for hook in *slime-repl-eval-hooks* - for res = (catch *slime-repl-eval-hook-pass* - (multiple-value-list (funcall hook form))) - until (not (eq res *slime-repl-eval-hook-pass*)) - finally (if (eq res *slime-repl-eval-hook-pass*) - (multiple-value-list (eval form)) - res))) + for res = (catch *slime-repl-eval-hook-pass* + (multiple-value-list (funcall hook form))) + until (not (eq res *slime-repl-eval-hook-pass*)) + finally (return + (if (eq res *slime-repl-eval-hook-pass*) + (multiple-value-list (eval form)) + res)))) (defun package-string-for-prompt (package) "Return the shortest nickname (or canonical name) of PACKAGE." Index: slime/slime.el diff -u slime/slime.el:1.542 slime/slime.el:1.543 --- slime/slime.el:1.542 Tue Sep 13 02:11:56 2005 +++ slime/slime.el Tue Sep 13 06:14:53 2005 @@ -5881,8 +5881,10 @@ (defvar slime-ed-frame nil "The frame used by `slime-ed'.") -(defvar slime-ed-use-dedicated-frame t - "*When non-nil, `slime-ed' will create and reuse a dedicated frame.") +(defcustom slime-ed-use-dedicated-frame t + "*When non-nil, `slime-ed' will create and reuse a dedicated frame." + :type 'boolean + :group 'slime) (defun slime-ed (what) "Edit WHAT. From aruttenberg at common-lisp.net Tue Sep 13 05:37:23 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Tue, 13 Sep 2005 07:37:23 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog slime/slime.el slime/swank.lisp slime/swank-openmcl.lisp Message-ID: <20050913053723.04DFA8855C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13328/slime Modified Files: ChangeLog slime.el swank.lisp swank-openmcl.lisp Log Message: Date: Tue Sep 13 07:37:22 2005 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.776 slime/ChangeLog:1.777 --- slime/ChangeLog:1.776 Tue Sep 13 06:14:53 2005 +++ slime/ChangeLog Tue Sep 13 07:37:16 2005 @@ -1,6 +1,29 @@ 2005-09-13 Alan Ruttenberg + * slime.el (defcustom slime-ed-use-dedicated-frame ... vs defvar - * swank.lisp (run-repl-eval-hooks .. finally (return vs no return + + (defcustom slime-when-complete-filename-expand: Use + comint-replace-by-expanded-filename instead of + comint-dynamic-complete-as-filename to complete file names + + * swank.lisp (run-repl-eval-hooks .. finally (return vs no return + + inspector-call-nth-action Allow second value :replace for inspector actions + + (defvar *slime-inspect-contents-limit* default nil. How many elements of + a hash table or array to show by default. If table has more than + this then offer actions to view more. Set to nil for no limit. Probably should + set default to reasonable value - I like 200. + + (inspect-for-emacs ((ht hash-table) inspector)) - banner line is hash table object. + Respect *slime-inspect-contents-limit* + + (defmethod inspect-for-emacs ((array array) inspector) + Respect *slime-inspect-contents-limit* + + * swank-openmcl.lisp inspector for closures shows closed-over + values. To be fixed: inspector-princ needs to be loaded earlier + since swank package not available when compiling 2005-09-13 Helmut Eller Index: slime/slime.el diff -u slime/slime.el:1.543 slime/slime.el:1.544 --- slime/slime.el:1.543 Tue Sep 13 06:14:53 2005 +++ slime/slime.el Tue Sep 13 07:37:16 2005 @@ -205,6 +205,11 @@ (const :tag "Compound" slime-complete-symbol*) (const :tag "Fuzzy" slime-fuzzy-complete-symbol))) +(defcustom slime-when-complete-filename-expand nil + "Use comint-replace-by-expanded-filename instead of comint-dynamic-complete-as-filename to complete file names" + :group 'slime-mode + :type 'boolean) + (defcustom slime-complete-symbol*-fancy nil "Use information from argument lists for DWIM'ish symbol completion." :group 'slime-mode @@ -5337,7 +5342,9 @@ Return nil iff if point is not at filename." (if (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t)) (let ((comint-completion-addsuffix '("/" . "\""))) - (comint-dynamic-complete-as-filename) + (if slime-when-complete-filename-expand + (comint-replace-by-expanded-filename) + (comint-dynamic-complete-as-filename)) t) nil)) @@ -5471,7 +5478,9 @@ (interactive) (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t)) (return-from slime-fuzzy-complete-symbol - (comint-dynamic-complete-as-filename))) + (if slime-when-complete-filename-expand + (comint-replace-by-expanded-filename) + (comint-dynamic-complete-as-filename)))) (let* ((end (move-marker (make-marker) (slime-symbol-end-pos))) (beg (move-marker (make-marker) (slime-symbol-start-pos))) (prefix (buffer-substring-no-properties beg end)) @@ -5884,7 +5893,7 @@ (defcustom slime-ed-use-dedicated-frame t "*When non-nil, `slime-ed' will create and reuse a dedicated frame." :type 'boolean - :group 'slime) + :group 'slime-mode) (defun slime-ed (what) "Edit WHAT. Index: slime/swank.lisp diff -u slime/swank.lisp:1.333 slime/swank.lisp:1.334 --- slime/swank.lisp:1.333 Tue Sep 13 06:14:53 2005 +++ slime/swank.lisp Tue Sep 13 07:37:16 2005 @@ -1830,7 +1830,6 @@ (if *slime-repl-eval-hooks* (setq values (run-repl-eval-hooks form)) (setq values (multiple-value-list (eval form)))) - (ccl::print-db values) (force-output))))) (when (and package-update-p (not (eq *package* *buffer-package*))) (send-to-emacs @@ -3313,9 +3312,13 @@ ((and (eq fast slow) (> n 0)) (return nil)) ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast))))))) +(defvar *slime-inspect-contents-limit* nil "How many elements of + a hash table or array to show by default. If table has more than + this then offer actions to view more. Set to nil for no limit." ) + (defmethod inspect-for-emacs ((ht hash-table) inspector) (declare (ignore inspector)) - (values "A hash table." + (values (prin1-to-string ht) (append (label-value-line* ("Count" (hash-table-count ht)) @@ -3324,9 +3327,48 @@ ("Rehash size" (hash-table-rehash-size ht)) ("Rehash threshold" (hash-table-rehash-threshold ht))) '("Contents: " (:newline)) + (if (and *slime-inspect-contents-limit* + (>= (hash-table-count ht) *slime-inspect-contents-limit*)) + (inspect-bigger-piece-actions ht (hash-table-count ht)) + nil) (loop for key being the hash-keys of ht - for value being the hash-values of ht - append `((:value ,key) " = " (:value ,value) (:newline)))))) + for value being the hash-values of ht + repeat (or *slime-inspect-contents-limit* most-positive-fixnum) + append `((:value ,key) " = " (:value ,value) (:newline)) + ) + + ))) + +(defmethod inspect-bigger-piece-actions (thing size) + (append + (if (> size *slime-inspect-contents-limit*) + (list (inspect-factor-more-action thing) + '(:newline)) + nil) + (list (inspect-whole-thing-action thing size) + '(:newline)))) + +(defmethod inspect-whole-thing-action (thing size) + `(:action ,(format nil "Inspect all ~a elements." + size) + ,(lambda() + (let ((*slime-inspect-contents-limit* nil)) + (values + (swank::inspect-object thing) + :replace) + )))) + +(defmethod inspect-factor-more-action (thing) + `(:action ,(format nil "~a elements shown. Prompt for how many to inspect..." + *slime-inspect-contents-limit* ) + ,(lambda() + (let ((*slime-inspect-contents-limit* + (read))) + (values + (swank::inspect-object thing) + :replace) + )) + )) (defmethod inspect-for-emacs ((array array) inspector) (declare (ignore inspector)) @@ -3340,7 +3382,11 @@ (when (array-has-fill-pointer-p array) (label-value-line "Fill pointer" (fill-pointer array))) '("Contents:" (:newline)) - (loop for i below (array-total-size array) + (if (and *slime-inspect-contents-limit* + (>= (array-total-size array) *slime-inspect-contents-limit*)) + (inspect-bigger-piece-actions array (length array)) + nil) + (loop for i below (or *slime-inspect-contents-limit* (array-total-size array)) append (label-value-line i (row-major-aref array i)))))) (defmethod inspect-for-emacs ((char character) inspector) @@ -3893,9 +3939,11 @@ (with-buffer-syntax () (inspect-object (inspector-nth-part index)))) -(defslimefun inspector-call-nth-action (index) - (funcall (aref *inspectee-actions* index)) - (inspect-object (pop *inspector-stack*))) +(defslimefun inspector-call-nth-action (index &rest args) + (multiple-value-bind (value replace) (apply (aref *inspectee-actions* index) args) + (if (eq replace :replace) + value + (inspect-object (pop *inspector-stack*))))) (defslimefun inspector-pop () "Drop the inspector stack and inspect the second element. Return Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.99 slime/swank-openmcl.lisp:1.100 --- slime/swank-openmcl.lisp:1.99 Fri Sep 9 04:01:10 2005 +++ slime/swank-openmcl.lisp Tue Sep 13 07:37:16 2005 @@ -735,6 +735,38 @@ collect `(:value ,(ccl::uvref object index)) collect `(:newline))))) +(defun closure-closed-over-values (closure) + (let ((howmany (nth-value 8 (ccl::function-args (ccl::closure-function closure))))) + (loop for n below howmany + collect + (let* ((value (ccl::%svref closure (+ 1 (- howmany n)))) + (map (car (ccl::function-symbol-map (ccl::closure-function closure)))) + (label (or (and map (svref map n)) n)) + (cellp (ccl::closed-over-value-p value))) + (list label (if cellp (ccl::closed-over-value value) value)))))) + +(defmethod inspect-for-emacs ((c ccl::compiled-lexical-closure) (inspector t)) + (declare (ignore inspector)) + (values + (format nil "A closure: ~a" c) + `(,@(if (arglist c) + (list "Its argument list is: " + (funcall (intern "INSPECTOR-PRINC" 'swank) (arglist c))) + ;; FIXME inspector-princ should load earlier + (list "A function of no arguments")) + (:newline) + ,@(when (documentation c t) + `("Documentation:" (:newline) ,(documentation c t) (:newline))) + ,(format nil "Closed over ~a values" (length (closure-closed-over-values c))) + (:newline) + ,@(loop for (name value) in (closure-closed-over-values c) + for count from 1 + append + (label-value-line* ((format nil "~2,' d) ~a" count (string name)) value)))))) + + + + ;;; Multiprocessing (defvar *known-processes* '() ; FIXME: leakage. -luke From mkoeppe at common-lisp.net Wed Sep 14 20:17:44 2005 From: mkoeppe at common-lisp.net (Matthias Koeppe) Date: Wed, 14 Sep 2005 22:17:44 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050914201744.5BE158853E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16553 Modified Files: slime.el Log Message: (slime-presentation-expression): Remove handling of cons presentation-ids. Date: Wed Sep 14 22:17:43 2005 Author: mkoeppe Index: slime/slime.el diff -u slime/slime.el:1.544 slime/slime.el:1.545 --- slime/slime.el:1.544 Tue Sep 13 07:37:16 2005 +++ slime/slime.el Wed Sep 14 22:17:42 2005 @@ -3158,14 +3158,7 @@ the presented object." (let ((id (slime-presentation-id presentation))) ;; Make sure it works even if *read-base* is not 10. - (cond - ((and (consp id) (integerp (car id)) (integerp (cdr id))) - (format "(swank:get-repl-result '(#10r%d . #10r%d))" (car id) (cdr id))) - ((integerp id) - (format "(swank:get-repl-result #10r%d)" id)) - (t - (slime-prin1-to-string - `(swank:get-repl-result ',id)))))) + (format "(swank:get-repl-result #10r%d)" id))) (defun slime-buffer-substring-with-reified-output (start end) (let ((str-props (buffer-substring start end)) From mkoeppe at common-lisp.net Wed Sep 14 20:18:40 2005 From: mkoeppe at common-lisp.net (Matthias Koeppe) Date: Wed, 14 Sep 2005 22:18:40 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050914201840.160F38853E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16587 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Sep 14 22:18:39 2005 Author: mkoeppe Index: slime/ChangeLog diff -u slime/ChangeLog:1.777 slime/ChangeLog:1.778 --- slime/ChangeLog:1.777 Tue Sep 13 07:37:16 2005 +++ slime/ChangeLog Wed Sep 14 22:18:39 2005 @@ -1,3 +1,8 @@ +2005-09-14 Matthias Koeppe + + * slime.el (slime-presentation-expression): Remove handling of + cons presentation-ids. + 2005-09-13 Alan Ruttenberg * slime.el (defcustom slime-ed-use-dedicated-frame ... vs defvar From aruttenberg at common-lisp.net Thu Sep 15 03:37:15 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Thu, 15 Sep 2005 05:37:15 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog slime/slime.el slime/swank.lisp Message-ID: <20050915033715.7DDB088549@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14396/slime Modified Files: ChangeLog slime.el swank.lisp Log Message: * slime.el (slime-menu-choices-for-presentation), (slime-presentation-menu) Fix loss after refactoring. xemacs can't handle lambda forms in the menu spec given to x-popup-menu, only symbols, so save the actions in a hash table keyed by a gensym, give x-popup-menu the gensym and then call the gensym. Haven't checked that it actually works in xemacs because my xemacs is hosed in os x Tiger. Could someone let me know... * swank.lisp (inspect-factor-more-action) rename (inspect-show-more-action) Prompt before reading how many more. Would be nicer to prompt in the minibuffer... Date: Thu Sep 15 05:37:14 2005 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.778 slime/ChangeLog:1.779 --- slime/ChangeLog:1.778 Wed Sep 14 22:18:39 2005 +++ slime/ChangeLog Thu Sep 15 05:37:13 2005 @@ -1,3 +1,17 @@ +2005-09-14 Alan Ruttenberg + + * slime.el (slime-menu-choices-for-presentation), (slime-presentation-menu) + Fix loss after refactoring. xemacs can't handle lambda forms in + the menu spec given to x-popup-menu, only symbols, so save the + actions in a hash table keyed by a gensym, give x-popup-menu the + gensym and then call the gensym. Haven't checked that it actually + works in xemacs because my xemacs is hosed in os x Tiger. Could + someone let me know... + + * swank.lisp (inspect-factor-more-action) + rename (inspect-show-more-action) Prompt before reading how many + more. Would be nicer to prompt in the minibuffer... + 2005-09-14 Matthias Koeppe * slime.el (slime-presentation-expression): Remove handling of Index: slime/slime.el diff -u slime/slime.el:1.545 slime/slime.el:1.546 --- slime/slime.el:1.545 Wed Sep 14 22:17:42 2005 +++ slime/slime.el Thu Sep 15 05:37:13 2005 @@ -3024,57 +3024,63 @@ ;; 2. Let used choose ;; 3. Call back to execute menu choice, passing nth and string of choice -(defun slime-menu-choices-for-presentation (presentation from to) +(defun slime-menu-choices-for-presentation (presentation from to choice-to-lambda) "Return a menu for `presentation' at `from'--`to' in the current buffer, suitable for `x-popup-menu'." (let* ((what (slime-presentation-id presentation)) (choices (slime-eval `(swank::menu-choices-for-presentation-id ',what)))) + (flet ((savel (f) ;; IMPORTANT - xemacs can't handle lambdas in x-popup-menu. So give them a name + (let ((sym (gensym))) + (setf (gethash sym choice-to-lambda) f) + sym))) (etypecase choices (list `(,(if (featurep 'xemacs) " " "") ("" - ("Inspect" . (lambda () + ("Inspect" . ,(savel `(lambda () (interactive) - (slime-inspect-presented-object ',what))) + (slime-inspect-presented-object ',what)))) ("Describe" . - (lambda () + ,(savel `(lambda () (interactive) ;; XXX remove call to describe. (slime-eval '(cl:describe - (swank::lookup-presented-object ',what))))) - ("Copy to input" . slime-copy-presentation-at-point) + (swank::lookup-presented-object ',what)))))) + ("Copy to input" . ,(savel 'slime-copy-presentation-at-point)) ,@(let ((nchoice 0)) (mapcar (lambda (choice) (incf nchoice) (cons choice - `(lambda () + (savel `(lambda () (interactive) (slime-eval '(swank::execute-menu-choice-for-presentation-id - ',what ,nchoice ,(nth (1- nchoice) choices)))))) + ',what ,nchoice ,(nth (1- nchoice) choices))))))) choices))))) (symbol ; not-present (slime-remove-presentation-properties from to presentation) (sit-for 0) ; allow redisplay `("Object no longer recorded" - ("sorry" . ,(if (featurep 'xemacs) nil '(nil)))))))) + ("sorry" . ,(if (featurep 'xemacs) nil '(nil))))))))) (defun slime-presentation-menu (event) (interactive "e") (let* ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event)))) - (window (if (featurep 'xemacs) (event-window event) (caadr event)))) + (window (if (featurep 'xemacs) (event-window event) (caadr event))) + (choice-to-lambda (make-hash-table))) (with-current-buffer (window-buffer window) (multiple-value-bind (presentation from to) (slime-presentation-around-point point) (unless presentation (error "No presentation at event position")) (let ((menu (slime-menu-choices-for-presentation - presentation from to))) + presentation from to choice-to-lambda))) + (setq it choice-to-lambda) (let ((choice (x-popup-menu event menu))) (when choice - (call-interactively choice)))))))) + (call-interactively (gethash choice choice-to-lambda))))))))) (defun slime-repl-insert-prompt (result &optional time) "Goto to point max, insert RESULT and the prompt. Index: slime/swank.lisp diff -u slime/swank.lisp:1.334 slime/swank.lisp:1.335 --- slime/swank.lisp:1.334 Tue Sep 13 07:37:16 2005 +++ slime/swank.lisp Thu Sep 15 05:37:13 2005 @@ -3363,7 +3363,7 @@ *slime-inspect-contents-limit* ) ,(lambda() (let ((*slime-inspect-contents-limit* - (read))) + (progn (format t "How many elements should be shown? ") (read)))) (values (swank::inspect-object thing) :replace) From aruttenberg at common-lisp.net Thu Sep 15 04:42:06 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Thu, 15 Sep 2005 06:42:06 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050915044206.2FF9D88549@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18877/slime Modified Files: swank.lisp Log Message: Date: Thu Sep 15 06:42:06 2005 Author: aruttenberg Index: slime/swank.lisp diff -u slime/swank.lisp:1.335 slime/swank.lisp:1.336 --- slime/swank.lisp:1.335 Thu Sep 15 05:37:13 2005 +++ slime/swank.lisp Thu Sep 15 06:42:06 2005 @@ -3342,7 +3342,7 @@ (defmethod inspect-bigger-piece-actions (thing size) (append (if (> size *slime-inspect-contents-limit*) - (list (inspect-factor-more-action thing) + (list (inspect-show-more-action thing) '(:newline)) nil) (list (inspect-whole-thing-action thing size) @@ -3358,7 +3358,7 @@ :replace) )))) -(defmethod inspect-factor-more-action (thing) +(defmethod inspect-show-more-action (thing) `(:action ,(format nil "~a elements shown. Prompt for how many to inspect..." *slime-inspect-contents-limit* ) ,(lambda() From heller at common-lisp.net Thu Sep 15 08:17:40 2005 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 15 Sep 2005 10:17:40 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp Message-ID: <20050915081740.808068854B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv1761 Modified Files: swank-clisp.lisp Log Message: (compute-backtrace): Include only "function frames" in the backtrace. I hope that makes some sense. (sldb-backtrace, function-frame-p): New functions. (*sldb-backtrace*, call-with-debugging-environment, nth-frame): Compute and remember the backtrace when entering the debugger. (arglist): If the function has a function-lambda-expression, fetch the arglist from there. (find-encoding): Use strings instead of 'charset:foo symbols to avoid compile time problems if the charset is not available. Suggested by Vaucher Laurent. Date: Thu Sep 15 10:17:39 2005 Author: heller Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.55 slime/swank-clisp.lisp:1.56 --- slime/swank-clisp.lisp:1.55 Tue Sep 13 00:58:17 2005 +++ slime/swank-clisp.lisp Thu Sep 15 10:17:38 2005 @@ -118,13 +118,11 @@ (socket:socket-server-close socket)) (defun find-encoding (external-format) - (ecase external-format - (:iso-latin-1-unix (ext:make-encoding :charset 'charset:iso-8859-1 - :line-terminator :unix)) - (:utf-8-unix (ext:make-encoding :charset 'charset:utf-8 - :line-terminator :unix)) - (:euc-jp-unix (ext:make-encoding :charset 'charset:euc-jp - :line-terminator :unix)))) + (let ((charset (ecase external-format + (:iso-latin-1-unix "iso-8859-1") + (:utf-8-unix "utf-8") + (:euc-jp-unix "euc-jp")))) + (ext:make-encoding :charset charset :line-terminator :unix))) (defimplementation accept-connection (socket &key (external-format :iso-latin-1-unix)) @@ -137,7 +135,11 @@ (defimplementation arglist (fname) (block nil - (or (ignore-errors (return (ext:arglist fname))) + (or (ignore-errors + (let ((exp (function-lambda-expression fname))) + (and exp (return (second exp))))) + (ignore-errors + (return (ext:arglist fname))) :not-available))) (defimplementation macroexpand-all (form) @@ -226,61 +228,97 @@ (defimplementation find-definitions (name) (list (list name (fspec-location name)))) -(defvar *sldb-topframe*) -(defvar *sldb-botframe*) -(defvar *sldb-source*) -(defvar *sldb-debugmode* 4) +(defun trim-whitespace (string) + (string-trim #(#\newline #\space #\tab) string)) -(defun frame-down (frame) - (sys::frame-down-1 frame sys::*debug-mode*)) - -(defun frame-up (frame) - (sys::frame-up-1 frame sys::*debug-mode*)) +(defvar *sldb-backtrace*) (defimplementation call-with-debugging-environment (debugger-loop-fn) (let* ((sys::*break-count* (1+ sys::*break-count*)) (sys::*driver* debugger-loop-fn) (sys::*fasoutput-stream* nil) - (sys::*frame-limit1* (sys::frame-limit1 0)) - (sys::*frame-limit2* (sys::frame-limit2)) - (sys::*debug-mode* *sldb-debugmode*) - (*sldb-topframe* sys::*frame-limit1*)) + (*sldb-backtrace* (nthcdr 6 (sldb-backtrace)))) (funcall debugger-loop-fn))) -(defun nth-frame (index) - (loop for frame = *sldb-topframe* then (frame-up frame) - repeat index - finally (return frame))) +(defun nth-frame (index) + (nth index *sldb-backtrace*)) + +;; This is the old backtrace implementation. Not sure yet wheter the +;; new is much better. +;; +;;(defimplementation compute-backtrace (start end) +;; (let ((end (or end most-positive-fixnum))) +;; (loop for last = nil then frame +;; for frame = (nth-frame start) then (frame-up frame) +;; for i from start below end +;; until (or (eq frame last) (not frame)) +;; collect frame))) +;; +;;(defimplementation print-frame (frame stream) +;; (write-string (trim-whitespace +;; (with-output-to-string (stream) +;; (sys::describe-frame stream frame))) +;; stream)) +;; +;;(defimplementation frame-locals (frame-number) +;; (let* ((frame (nth-frame frame-number)) +;; (frame-env (sys::eval-at frame '(sys::the-environment)))) +;; (append +;; (frame-do-venv frame (svref frame-env 0)) +;; (frame-do-fenv frame (svref frame-env 1)) +;; (frame-do-benv frame (svref frame-env 2)) +;; (frame-do-genv frame (svref frame-env 3)) +;; (frame-do-denv frame (svref frame-env 4))))) +;; +;;(defimplementation frame-var-value (frame var) +;; (getf (nth var (frame-locals frame)) :value)) + +(defun format-frame (frame) + (trim-whitespace + (with-output-to-string (s) + (sys::describe-frame s frame)))) + +(defun function-frame-p (frame) + ;; We are interested in frames which like look "<5> foo ...". + ;; Ugly, I know. + (char= #\< (aref (format-frame frame) 0))) + +(defun sldb-backtrace () + "Return a list ((ADDRESS . DESCRIPTION) ...) of frames." + (do ((fframes '()) + (last nil frame) + (frame (sys::the-frame) (sys::frame-up-1 frame 1))) + ((eq frame last) (nreverse fframes)) + (when (function-frame-p frame) + (push (cons frame (format-frame frame)) fframes)))) (defimplementation compute-backtrace (start end) - (let ((end (or end most-positive-fixnum))) - (loop for last = nil then frame - for frame = (nth-frame start) then (frame-up frame) - for i from start below end - until (or (eq frame last) (system::driver-frame-p frame)) - collect frame))) + (let* ((bt *sldb-backtrace*) + (len (length bt))) + (subseq bt start (min (or end len) len)))) (defimplementation print-frame (frame stream) - (write-string (string-left-trim '(#\Newline) - (with-output-to-string (stream) - (sys::describe-frame stream frame))) - stream)) + (let ((desc (cdr frame))) + (write-string (subseq (cdr frame) + (+ (position #\> desc) 2) + (position #\newline desc)) + stream))) + +(defimplementation format-sldb-condition (condition) + (trim-whitespace (princ-to-string condition))) (defimplementation eval-in-frame (form frame-number) - (sys::eval-at (nth-frame frame-number) form)) + (sys::eval-at (car (nth-frame frame-number)) form)) -(defimplementation frame-locals (frame-number) - (let* ((frame (nth-frame frame-number)) - (frame-env (sys::eval-at frame '(sys::the-environment)))) - (append - (frame-do-venv frame (svref frame-env 0)) - (frame-do-fenv frame (svref frame-env 1)) - (frame-do-benv frame (svref frame-env 2)) - (frame-do-genv frame (svref frame-env 3)) - (frame-do-denv frame (svref frame-env 4))))) +;; Don't know how to access locals. Return some strings instead. +;; Maybe we should search some frame nearby with a 'sys::the-environment? +(defimplementation frame-locals (frame-number) + (let ((desc (cdr (nth-frame frame-number)))) + (list (list :name :|| :id 0 + :value (trim-whitespace + (subseq desc (position #\newline desc))))))) -(defimplementation frame-var-value (frame var) - (getf (nth var (frame-locals frame)) :value)) +(defimplementation frame-var-value (frame var) nil) ;; Interpreter-Variablen-Environment has the shape ;; NIL or #(v1 val1 ... vn valn NEXT-ENV). @@ -317,13 +355,13 @@ nil) (defimplementation return-from-frame (index form) - (sys::return-from-eval-frame (nth-frame index) form)) + (sys::return-from-eval-frame (car (nth-frame index)) form)) (defimplementation restart-frame (index) - (sys::redo-eval-frame (nth-frame index))) + (sys::redo-eval-frame (car (nth-frame index)))) (defimplementation frame-source-location-for-emacs (index) - (let ((f (nth-frame index))) + (let ((f (car (nth-frame index)))) (list :error (format nil "Cannot find source for frame: ~A ~A ~A" f (sys::eval-frame-p f) From heller at common-lisp.net Thu Sep 15 08:25:43 2005 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 15 Sep 2005 10:25:43 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050915082543.BAECC880DE@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv1889 Modified Files: slime.el Log Message: (slime-process-available-input): Simplify it a bit and make it easier to debug read errors. (slime-net-close): Don't kill the buffer if the new optional arg `debug' is true. (slime-run-when-idle): Accept arguments for the function. (slime-init-connection-state): Close over the proc variable. It was lost when the async evaluation returned. (slime-output-buffer, slime-connection-output-buffer): Make slime-output-buffer faster by keeping the buffer in a connection variable. (slime-restart-inferior-lisp-aux, slime-quit-lisp): Disable the process filter to avoid errors in XEmacs. Date: Thu Sep 15 10:25:42 2005 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.546 slime/slime.el:1.547 --- slime/slime.el:1.546 Thu Sep 15 05:37:13 2005 +++ slime/slime.el Thu Sep 15 10:25:42 2005 @@ -171,6 +171,12 @@ :type 'function :group 'slime-lisp) +(defcustom slime-enable-evaluate-in-emacs nil + "*If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs. +The default is nil, as this feature can be a security risk." + :type '(boolean) + :group 'slime-lisp) + ;;;;; slime-mode (defgroup slime-mode nil @@ -879,8 +885,6 @@ (setq slime-pre-command-actions nil)) (defun slime-post-command-hook () - (when (and slime-mode (slime-connected-p)) - (slime-process-available-input)) (when (null pre-command-hook) ; sometimes this is lost (add-hook 'pre-command-hook 'slime-pre-command-hook))) @@ -1648,12 +1652,17 @@ (and (not (multibyte-string-p string)) (not (slime-coding-system-mulibyte-p coding-system)))))) -(defun slime-net-close (process) +(defun slime-net-close (process &optional debug) (setq slime-net-processes (remove process slime-net-processes)) (when (eq process slime-default-connection) (setq slime-default-connection nil)) - (run-hook-with-args 'slime-net-process-close-hooks process) - (ignore-errors (kill-buffer (process-buffer process)))) + (cond (debug + (set-process-sentinel process 'ignore) + (delete-process process)) + (t + (run-hook-with-args 'slime-net-process-close-hooks process) + ;; killing the buffer also closes the socket + (kill-buffer (process-buffer process))))) (defun slime-net-sentinel (process message) (message "Lisp connection closed unexpectedly: %s" message) @@ -1664,41 +1673,32 @@ ;;; complete messages and hands them off to the event dispatcher. (defun slime-net-filter (process string) - "Accept output from the socket and input all complete messages." + "Accept output from the socket and process all complete messages." (with-current-buffer (process-buffer process) - (save-excursion - (goto-char (point-max)) - (insert string)) - (slime-process-available-input))) + (goto-char (point-max)) + (insert string)) + (slime-process-available-input process)) -(defun slime-run-when-idle (function) +(defun slime-run-when-idle (function &rest args) "Call FUNCTION as soon as Emacs is idle." - (cond ((featurep 'xemacs) - (run-at-time itimer-short-interval nil - (lambda (f) (funcall f)) function)) - (t (run-at-time 0 nil function)))) + (apply #'run-at-time + (if (featurep 'xemacs) itimer-short-interval 0) + nil function args)) -(defun slime-process-available-input () +(defun slime-process-available-input (process) "Process all complete messages that have arrived from Lisp." - (unwind-protect - (dolist (proc slime-net-processes) - (with-current-buffer (process-buffer proc) - (while (slime-net-have-input-p) - (let ((event (condition-case error - (slime-net-read) - (error - (message "net-read error: %S" error) - (ding) - (sleep-for 2) - (ignore-errors (slime-net-close proc)) - (error "PANIC!"))))) - (save-current-buffer - (slime-log-event event) - (slime-dispatch-event event proc)))))) - (dolist (p slime-net-processes) - (with-current-buffer (process-buffer p) - (when (slime-net-have-input-p) - (slime-run-when-idle 'slime-process-available-input)))))) + (with-current-buffer (process-buffer process) + (while (slime-net-have-input-p) + (let ((event (condition-case error + (slime-net-read) + (error + (slime-net-close process t) + (error "net-read error: %S" error))))) + (slime-log-event event) + (unwind-protect + (save-current-buffer (slime-dispatch-event event process)) + (when (slime-net-have-input-p) + (slime-run-when-idle 'slime-process-available-input process))))))) (defun slime-net-have-input-p () "Return true if a complete message is available." @@ -1713,13 +1713,13 @@ (start (+ 6 (point))) (end (+ start length))) (assert (plusp length)) - (let ((string (buffer-substring start end))) + (let ((string (buffer-substring-no-properties start end))) (prog1 (read string) (delete-region (point-min) end))))) (defun slime-net-decode-length () "Read a 24-bit hex-encoded integer from buffer." - (string-to-number (buffer-substring (point) (+ (point) 6)) 16)) + (string-to-number (buffer-substring-no-properties (point) (+ (point) 6)) 16)) (defun slime-net-encode-length (n) "Encode an integer into a 24-bit hex string." @@ -1952,25 +1952,27 @@ ;; be called from a timer, and if we setup the REPL from a timer ;; then it mysteriously uses the wrong keymap for the first command. (slime-eval-async '(swank:connection-info) - (lambda (info) - (slime-set-connection-info proc info)))) + (lexical-let ((proc proc)) + (lambda (info) + (slime-set-connection-info proc info))))) (defun slime-set-connection-info (connection info) "Initialize CONNECTION with INFO received from Lisp." - (destructuring-bind (pid type name features style version host) info - (setf (slime-pid) pid - (slime-lisp-implementation-type) type - (slime-lisp-implementation-type-name) name - (slime-connection-name) (slime-generate-connection-name name) - (slime-lisp-features) features - (slime-communication-style) style - (slime-lisp-implementation-version) version - (slime-machine-instance) host)) - (setq slime-state-name "") ; FIXME - (slime-hide-inferior-lisp-buffer) - (slime-init-output-buffer connection) - (run-hooks 'slime-connected-hook) - (message "Connected. %s" (slime-random-words-of-encouragement))) + (let ((slime-dispatching-connection connection)) + (destructuring-bind (pid type name features style version host) info + (setf (slime-pid) pid + (slime-lisp-implementation-type) type + (slime-lisp-implementation-type-name) name + (slime-connection-name) (slime-generate-connection-name name) + (slime-lisp-features) features + (slime-communication-style) style + (slime-lisp-implementation-version) version + (slime-machine-instance) host)) + (setq slime-state-name "") ; FIXME + (slime-hide-inferior-lisp-buffer) + (slime-init-output-buffer connection) + (run-hooks 'slime-connected-hook) + (message "Connected. %s" (slime-random-words-of-encouragement)))) (defun slime-generate-connection-name (lisp-name) (loop for i from 1 @@ -2280,12 +2282,6 @@ (slime-def-connection-var slime-continuation-counter 0 "Continuation serial number counter.") -(defcustom slime-enable-evaluate-in-emacs nil - "If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs. -The default is nil, as this feature can be a security risk." - :type '(boolean) - :group 'slime-lisp) - (defun slime-dispatch-event (event &optional process) (let ((slime-dispatching-connection (or process (slime-connection)))) (destructure-case event @@ -2345,13 +2341,10 @@ ((:open-dedicated-output-stream port) (slime-open-stream-to-lisp port)) ((:eval-no-wait fun args) - (if slime-enable-evaluate-in-emacs - (apply (intern fun) args) - (error "Cannot evaluate in Emacs because slime-enable-evaluate-in-emacs is nil"))) + (slime-check-eval-in-emacs-enabled) + (apply (intern fun) args)) ((:eval thread tag fun args) - (if slime-enable-evaluate-in-emacs - (slime-eval-for-lisp thread tag (intern fun) args) - (slime-eval-async `(cl:error "Cannot evaluate in Emacs because slime-enable-evaluate-in-emacs is nil")))) + (slime-eval-for-lisp thread tag (intern fun) args)) ((:emacs-return thread tag value) (slime-send `(:emacs-return ,thread ,tag ,value))) ((:ed what) @@ -2429,6 +2422,9 @@ ;;;; Stream output +(slime-def-connection-var slime-connection-output-buffer nil + "The buffer for the REPL. May be nil or a dead buffer.") + (defcustom slime-header-line-p t "If non-nil, display a header line in Slime buffers." :type 'boolean @@ -2457,15 +2453,17 @@ (defun slime-output-buffer (&optional noprompt) "Return the output buffer, create it if necessary." - (or (slime-repl-buffer) - (let ((connection (slime-connection))) - (with-current-buffer (slime-repl-buffer t) - (slime-repl-mode) - (setq slime-buffer-connection connection) - (slime-reset-repl-markers) - (unless noprompt - (slime-repl-insert-prompt '(:suppress-output) 0)) - (current-buffer))))) + (let ((buffer (slime-connection-output-buffer))) + (or (if (buffer-live-p buffer) buffer) + (setf (slime-connection-output-buffer) + (let ((connection (slime-connection))) + (with-current-buffer (slime-repl-buffer t connection) + (slime-repl-mode) + (setq slime-buffer-connection connection) + (slime-reset-repl-markers) + (unless noprompt + (slime-repl-insert-prompt '(:suppress-output) 0)) + (current-buffer))))))) (defun slime-repl-update-banner () (let* ((banner (format "%s Port: %s Pid: %s" @@ -2570,9 +2568,9 @@ (> (- slime-output-end slime-output-start) 1000))))) (defun slime-output-filter (process string) - (when (and (slime-connected-p) - (plusp (length string))) - (with-current-buffer (process-buffer process) + (with-current-buffer (process-buffer process) + (when (and (plusp (length string)) + (eq (process-status slime-buffer-connection) 'open)) (slime-output-string string)))) ;; FIXME: This conditional is not right - just used because the code @@ -3086,7 +3084,7 @@ "Goto to point max, insert RESULT and the prompt. Set slime-output-end to start of the inserted text slime-input-start to end end." - (slime-flush-output) + ;;(slime-flush-output) (goto-char (point-max)) (let ((start (point))) (unless (bolp) (insert "\n")) @@ -3246,10 +3244,10 @@ (defun slime-repl-bol () "Go to the beginning of line or the prompt." (interactive) - (if (and (>= (point) slime-repl-input-start-mark) - (slime-same-line-p (point) slime-repl-input-start-mark)) - (goto-char slime-repl-input-start-mark) - (beginning-of-line 1)) + (cond ((and (>= (point) slime-repl-input-start-mark) + (slime-same-line-p (point) slime-repl-input-start-mark)) + (goto-char slime-repl-input-start-mark)) + (t (beginning-of-line 1))) (slime-preserve-zmacs-region)) (defun slime-repl-eol () @@ -3894,6 +3892,7 @@ (defun slime-restart-inferior-lisp-aux () (interactive) (slime-eval-async '(swank:quit-lisp)) + (set-process-filter (slime-connection) nil) (set-process-sentinel (slime-connection) 'slime-restart-sentinel)) (defun slime-restart-sentinel (process message) @@ -5877,12 +5876,18 @@ (let ((ok nil) (value nil) (c (slime-connection))) - (unwind-protect (progn + (unwind-protect (progn + (slime-check-eval-in-emacs-enabled) (setq value (apply fun args)) (setq ok t)) (let ((result (if ok `(:ok ,value) `(:abort)))) (slime-dispatch-event `(:emacs-return ,thread ,tag ,result) c))))) +(defun slime-check-eval-in-emacs-enabled () + "Raise an error if `slime-enable-evaluate-in-emacs' isn't true." + (unless slime-enable-evaluate-in-emacs + (error "eval-in-emacs not enabled"))) + ;;;; `ED' @@ -6774,6 +6779,7 @@ (interactive) (slime-eval-async '(swank:quit-lisp)) (kill-buffer (slime-output-buffer)) + (set-process-filter (slime-connection) nil) (set-process-sentinel (slime-connection) 'slime-quit-sentinel)) (defun slime-quit-sentinel (process message) @@ -6783,7 +6789,6 @@ (when inferior (delete-process inferior)) (when inferior-buffer (kill-buffer inferior-buffer)) (slime-net-close process) - (slime-set-state "[not connected]" process) (message "Connection closed."))) (defun slime-set-package (package) @@ -9607,6 +9612,7 @@ slime-events-buffer slime-output-string slime-output-buffer + slime-connection-output-buffer slime-output-filter slime-repl-show-maximum-output slime-process-available-input From heller at common-lisp.net Thu Sep 15 08:28:08 2005 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 15 Sep 2005 10:28:08 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050915082808.F131C880DE@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv1976 Modified Files: swank.lisp Log Message: (eval-in-emacs): Fix a race condition which occurred with sigio. (*echo-area-prefix*): New variable. Date: Thu Sep 15 10:28:08 2005 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.336 slime/swank.lisp:1.337 --- slime/swank.lisp:1.336 Thu Sep 15 06:42:06 2005 +++ slime/swank.lisp Thu Sep 15 10:28:07 2005 @@ -1037,17 +1037,15 @@ (send-to-emacs `(:eval-no-wait ,fun ,args))) (t (force-output) - (let* ((tag (incf *read-input-catch-tag*))) - (send-to-emacs `(:eval ,(current-thread) ,tag ,fun ,args)) - (receive-eval-result tag))))))) - -(defun receive-eval-result (tag) - (let ((value (catch (intern-catch-tag tag) - (loop (read-from-emacs))))) - (destructure-case value - ((:ok value) value) - ((:abort) (abort))))) - + (let* ((tag (incf *read-input-catch-tag*)) + (value (catch (intern-catch-tag tag) + (send-to-emacs + `(:eval ,(current-thread) ,tag ,fun ,args)) + (loop (read-from-emacs))))) + (destructure-case value + ((:ok value) value) + ((:abort) (abort))))))))) + (defslimefun connection-info () "Return a list of the form: \(PID IMPLEMENTATION-TYPE IMPLEMENTATION-NAME FEATURES @@ -1061,6 +1059,18 @@ (lisp-implementation-version) (machine-instance))) +(defslimefun io-speed-test (n m) + (let ((s *standard-output*) + (*trace-output* *log-output*)) + (time (progn + (dotimes (i n) + (format s "~D abcdefghijklm~%" i) + (when (zerop (mod n m)) + (finish-output s))) + (finish-output s) + (eval-in-emacs '(message "done.")))) + nil)) + ;;;; Reading and printing @@ -1708,7 +1718,7 @@ (defun lookup-presented-object (id) "Retrieve the object corresponding to ID. -The secondary value indicates the a absence of an entry." +The secondary value indicates the absence of an entry." (gethash id *presentation-id-to-object*)) (defslimefun get-repl-result (id) @@ -1757,14 +1767,18 @@ ,(if ok `(:ok ,result) '(:abort)) ,id))))))) +(defvar *echo-area-prefix* "=> " + "A prefix that `format-values-for-echo-area' should use.") + (defun format-values-for-echo-area (values) (with-buffer-syntax () (let ((*print-readably* nil)) (cond ((null values) "; No value") ((and (null (cdr values)) (integerp (car values))) (let ((i (car values))) - (format nil "~D (#x~X, #o~O, #b~B)" i i i i))) - (t (format nil "~{~S~^, ~}" values)))))) + (format nil "~A~D (#x~X, #o~O, #b~B)" + *echo-area-prefix* i i i i))) + (t (format nil "~A~{~S~^, ~}" *echo-area-prefix* values)))))) (defslimefun interactive-eval (string) (with-buffer-syntax () @@ -1933,7 +1947,7 @@ collect (cons (prin1-to-string x) (save-presented-object x))))) (t - `(:values (mapcar #'prin1-to-string values)))))))) + `(:values ,(mapcar #'prin1-to-string values)))))))) (defslimefun ed-in-emacs (&optional what) "Edit WHAT in Emacs. From heller at common-lisp.net Thu Sep 15 08:31:50 2005 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 15 Sep 2005 10:31:50 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050915083150.0A3AF880DE@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv2902 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Thu Sep 15 10:31:50 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.779 slime/ChangeLog:1.780 --- slime/ChangeLog:1.779 Thu Sep 15 05:37:13 2005 +++ slime/ChangeLog Thu Sep 15 10:31:50 2005 @@ -1,3 +1,33 @@ +2005-09-15 Helmut Eller + + * swank-clisp.lisp (compute-backtrace): Include only "function + frames" in the backtrace. I hope that makes some sense. + (sldb-backtrace, function-frame-p): New functions. + (*sldb-backtrace*, call-with-debugging-environment, nth-frame): + Compute and remember the backtrace when entering the debugger. + (arglist): If the function has a function-lambda-expression, fetch + the arglist from there. + (find-encoding): Use strings instead of 'charset:foo symbols to + avoid compile time problems if the charset is not available. + Suggested by Vaucher Laurent. + + * swank.lisp (eval-in-emacs): Fix a race condition which occurred + with sigio. + (*echo-area-prefix*): New variable. + + * slime.el (slime-process-available-input): Simplify it a bit and + make it easier to debug read errors. + (slime-net-close): Don't kill the buffer if the new optional arg + `debug' is true. + (slime-run-when-idle): Accept arguments for the function. + (slime-init-connection-state): Close over the proc variable. It + was lost when the async evaluation returned. + (slime-output-buffer, slime-connection-output-buffer): Make + slime-output-buffer faster by keeping the buffer in a connection + variable. + (slime-restart-inferior-lisp-aux, slime-quit-lisp): Disable the + process filter to avoid errors in XEmacs. + 2005-09-14 Alan Ruttenberg * slime.el (slime-menu-choices-for-presentation), (slime-presentation-menu) @@ -66,7 +96,7 @@ * swank.lisp: Simplify the object <-> presentation-id mapping. (save-presented-object): Remove the optional `id' arg. - (lookup-presented-object): Id's should be fixnums not some cons + (lookup-presented-object): Id should be a fixnum not some cons with fuzzy/non-documented meaning. Use the secondary return value to test for absence of the id. Update callers accordingly. (*not-present*): Deleted. From aruttenberg at common-lisp.net Fri Sep 16 03:43:12 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 16 Sep 2005 05:43:12 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el slime/ChangeLog Message-ID: <20050916034312.387CF880DB@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18281/slime Modified Files: slime.el ChangeLog Log Message: (slime-repl-return) don't copy presentation to input if already in input area. Date: Fri Sep 16 05:43:08 2005 Author: aruttenberg Index: slime/slime.el diff -u slime/slime.el:1.547 slime/slime.el:1.548 --- slime/slime.el:1.547 Thu Sep 15 10:25:42 2005 +++ slime/slime.el Fri Sep 16 05:43:08 2005 @@ -3334,7 +3334,8 @@ (< (point) slime-repl-input-start-mark)) (slime-repl-grab-old-input end-of-input) (slime-repl-recenter-if-needed)) - ((car (slime-presentation-around-or-before-point (point))) + ((and (car (slime-presentation-around-or-before-point (point))) + (< (point) slime-repl-input-start-mark)) (slime-repl-grab-old-output end-of-input) (slime-repl-recenter-if-needed)) ((slime-input-complete-p slime-repl-input-start-mark Index: slime/ChangeLog diff -u slime/ChangeLog:1.780 slime/ChangeLog:1.781 --- slime/ChangeLog:1.780 Thu Sep 15 10:31:50 2005 +++ slime/ChangeLog Fri Sep 16 05:43:08 2005 @@ -1,3 +1,7 @@ +2005-09-15 Alan Ruttenberg + * slime.el (slime-repl-return) don't copy presentation to input if + already in input area. + 2005-09-15 Helmut Eller * swank-clisp.lisp (compute-backtrace): Include only "function From mkoeppe at common-lisp.net Sun Sep 18 14:34:33 2005 From: mkoeppe at common-lisp.net (Matthias Koeppe) Date: Sun, 18 Sep 2005 16:34:33 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050918143433.597928854E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6613 Modified Files: swank.lisp Log Message: Move presentation menu protocol here from present.lisp. Date: Sun Sep 18 16:34:32 2005 Author: mkoeppe Index: slime/swank.lisp diff -u slime/swank.lisp:1.337 slime/swank.lisp:1.338 --- slime/swank.lisp:1.337 Thu Sep 15 10:28:07 2005 +++ slime/swank.lisp Sun Sep 18 16:34:31 2005 @@ -4208,6 +4208,117 @@ (add-hook *pre-reply-hook* 'sync-indentation-to-emacs) + +;;;; Presentation menu protocol +;; +;; To define a menu for a type of object, define a method +;; menu-choices-for-presentation on that object type. This function +;; should return a list of two element lists where the first element is +;; the name of the menu action and the second is a function that will be +;; called if the menu is chosen. The function will be called with 3 +;; arguments: +;; +;; choice: The string naming the action from above +;; +;; object: The object +;; +;; id: The presentation id of the object +;; +;; You might want append (when (next-method-p) (call-next-method)) to +;; pick up the Menu actions of superclasses. +;; + +(defvar *presentation-active-menu* nil) + +(defun menu-choices-for-presentation-id (id) + (multiple-value-bind (ob presentp) (lookup-presented-object id) + (cond ((not presentp) 'not-present) + (t + (let ((menu-and-actions (menu-choices-for-presentation ob))) + (setq *presentation-active-menu* (cons id menu-and-actions)) + (mapcar 'car menu-and-actions)))))) + +(defun swank-ioify (thing) + (cond ((keywordp thing) thing) + ((and (symbolp thing)(not (find #\: (symbol-name thing)))) + (intern (symbol-name thing) 'swank-io-package)) + ((consp thing) (cons (swank-ioify (car thing)) (swank-ioify (cdr thing)))) + (t thing))) + +(defun execute-menu-choice-for-presentation-id (id count item) + (let ((ob (lookup-presented-object id))) + (assert (equal id (car *presentation-active-menu*)) () + "Bug: Execute menu call for id ~a but menu has id ~a" + id (car *presentation-active-menu*)) + (let ((action (second (nth (1- count) (cdr *presentation-active-menu*))))) + (swank-ioify (funcall action item ob id))))) + +;; Default method +(defmethod menu-choices-for-presentation (ob) + (declare (ignore ob)) + nil) + +;; Pathname +(defmethod menu-choices-for-presentation ((ob pathname)) + (let* ((file-exists (ignore-errors (probe-file ob))) + (lisp-type (make-pathname :type "lisp")) + (source-file (and (not (member (pathname-type ob) '("lisp" "cl") :test 'equal)) + (let ((source (merge-pathnames lisp-type ob))) + (and (ignore-errors (probe-file source)) + source)))) + (fasl-file (and file-exists + (equal (ignore-errors + (namestring + (truename + (compile-file-pathname + (merge-pathnames lisp-type ob))))) + (namestring (truename ob)))))) + (remove nil + (list* + (and (and file-exists (not fasl-file)) + (list "Edit this file" + (lambda(choice object id) + (declare (ignore choice id)) + (ed-in-emacs (namestring (truename object))) + nil))) + (and file-exists + (list "Dired containing directory" + (lambda (choice object id) + (declare (ignore choice id)) + (ed-in-emacs (namestring + (truename + (merge-pathnames + (make-pathname :name "" :type "") object)))) + nil))) + (and fasl-file + (list "Load this fasl file" + (lambda (choice object id) + (declare (ignore choice id object)) + (load ob) + nil))) + (and fasl-file + (list "Delete this fasl file" + (lambda (choice object id) + (declare (ignore choice id object)) + (let ((nt (namestring (truename ob)))) + (when (y-or-n-p-in-emacs "Delete ~a? " nt) + (delete-file nt))) + nil))) + (and source-file + (list "Edit lisp source file" + (lambda (choice object id) + (declare (ignore choice id object)) + (ed-in-emacs (namestring (truename source-file))) + nil))) + (and source-file + (list "Load lisp source file" + (lambda(choice object id) + (declare (ignore choice id object)) + (load source-file) + nil))) + (and (next-method-p) (call-next-method)))))) + + ;; 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: From mkoeppe at common-lisp.net Sun Sep 18 14:35:03 2005 From: mkoeppe at common-lisp.net (Matthias Koeppe) Date: Sun, 18 Sep 2005 16:35:03 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/present.lisp Message-ID: <20050918143503.4A6458854E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6654 Modified Files: present.lisp Log Message: Move presentation menu protocol to swank.lisp. Date: Sun Sep 18 16:35:02 2005 Author: mkoeppe Index: slime/present.lisp diff -u slime/present.lisp:1.15 slime/present.lisp:1.16 --- slime/present.lisp:1.15 Tue Sep 13 01:07:21 2005 +++ slime/present.lisp Sun Sep 18 16:35:02 2005 @@ -145,116 +145,6 @@ (funcall continue))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; menu protocol -;; -;; To define a menu for a type of object, define a method -;; menu-choices-for-presentation on that object type. This function -;; should return a list of two element lists where the first element is -;; The name of the menu action and the second is a function that will be -;; called if the menu is chosen. The function will be called with 3 -;; arguments: -;; -;; choice: The string naming the action from above -;; -;; object: The object -;; -;; id: The presentation id of the object -;; -;; You might want append (when (next-method-p) (call-next-method)) to -;; pick up the Menu actions of superclasses. -;; - -(defvar *presentation-active-menu* nil) - -(defun menu-choices-for-presentation-id (id) - (multiple-value-bind (ob presentp) (lookup-presented-object id) - (cond ((not presentp) 'not-present) - (t - (let ((menu-and-actions (menu-choices-for-presentation ob))) - (setq *presentation-active-menu* (cons id menu-and-actions)) - (mapcar 'car menu-and-actions)))))) - -(defun swank-ioify (thing) - (cond ((keywordp thing) thing) - ((and (symbolp thing)(not (find #\: (symbol-name thing)))) - (intern (symbol-name thing) 'swank-io-package)) - ((consp thing) (cons (swank-ioify (car thing)) (swank-ioify (cdr thing)))) - (t thing))) - -(defun execute-menu-choice-for-presentation-id (id count item) - (let ((ob (lookup-presented-object id))) - (assert (equal id (car *presentation-active-menu*)) () - "Bug: Execute menu call for id ~a but menu has id ~a" - id (car *presentation-active-menu*)) - (let ((action (second (nth (1- count) (cdr *presentation-active-menu*))))) - (swank-ioify (funcall action item ob id))))) - -;; Default method -(defmethod menu-choices-for-presentation (ob) - (declare (ignore ob)) - nil) - -;; Pathname -(defmethod menu-choices-for-presentation ((ob pathname)) - (let* ((file-exists (ignore-errors (probe-file ob))) - (lisp-type (make-pathname :type "lisp")) - (source-file (and (not (member (pathname-type ob) '("lisp" "cl") :test 'equal)) - (let ((source (merge-pathnames lisp-type ob))) - (and (ignore-errors (probe-file source)) - source)))) - (fasl-file (and file-exists - (equal (ignore-errors - (namestring - (truename - (compile-file-pathname - (merge-pathnames lisp-type ob))))) - (namestring (truename ob)))))) - (remove nil - (list* - (and (and file-exists (not fasl-file)) - (list "Edit this file" - (lambda(choice object id) - (declare (ignore choice id)) - (ed-in-emacs (namestring (truename object))) - nil))) - (and file-exists - (list "Dired containing directory" - (lambda (choice object id) - (declare (ignore choice id)) - (ed-in-emacs (namestring - (truename - (merge-pathnames - (make-pathname :name "" :type "") object)))) - nil))) - (and fasl-file - (list "Load this fasl file" - (lambda (choice object id) - (declare (ignore choice id object)) - (load ob) - nil))) - (and fasl-file - (list "Delete this fasl file" - (lambda (choice object id) - (declare (ignore choice id object)) - (let ((nt (namestring (truename ob)))) - (when (y-or-n-p-in-emacs "Delete ~a? " nt) - (delete-file nt))) - nil))) - (and source-file - (list "Edit lisp source file" - (lambda (choice object id) - (declare (ignore choice id object)) - (ed-in-emacs (namestring (truename source-file))) - nil))) - (and source-file - (list "Load lisp source file" - (lambda(choice object id) - (declare (ignore choice id object)) - (load source-file) - nil))) - (and (next-method-p) (call-next-method)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Example: Tell openmcl and cmucl to always present unreadable objects. try (describe 'class) #+openmcl From mkoeppe at common-lisp.net Sun Sep 18 14:36:02 2005 From: mkoeppe at common-lisp.net (Matthias Koeppe) Date: Sun, 18 Sep 2005 16:36:02 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050918143602.48C4A8854E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6672 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Sep 18 16:36:01 2005 Author: mkoeppe Index: slime/ChangeLog diff -u slime/ChangeLog:1.781 slime/ChangeLog:1.782 --- slime/ChangeLog:1.781 Fri Sep 16 05:43:08 2005 +++ slime/ChangeLog Sun Sep 18 16:36:01 2005 @@ -1,3 +1,7 @@ +2005-09-18 Matthias Koeppe + + * swank.lisp: Move presentation menu protocol here from present.lisp. + 2005-09-15 Alan Ruttenberg * slime.el (slime-repl-return) don't copy presentation to input if already in input area. From wjenkner at common-lisp.net Sun Sep 18 16:23:23 2005 From: wjenkner at common-lisp.net (Wolfgang Jenkner) Date: Sun, 18 Sep 2005 18:23:23 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/bridge.el Message-ID: <20050918162323.1B26E88537@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14502 Modified Files: bridge.el Log Message: cl is required at macro expansion time (because of `block'). Reported by Matthew D Swank. Date: Sun Sep 18 18:23:23 2005 Author: wjenkner Index: slime/bridge.el diff -u slime/bridge.el:1.3 slime/bridge.el:1.4 --- slime/bridge.el:1.3 Fri Sep 9 03:43:11 2005 +++ slime/bridge.el Sun Sep 18 18:23:20 2005 @@ -65,6 +65,9 @@ ;;; ;;; ls | devgnu *scratch* +(eval-when-compile + (require 'cl)) + ;;;%Parameters (defvar bridge-hook nil "Hook called when a bridge is installed by install-hook.") From wjenkner at common-lisp.net Sun Sep 18 16:25:17 2005 From: wjenkner at common-lisp.net (Wolfgang Jenkner) Date: Sun, 18 Sep 2005 18:25:17 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050918162517.D4B9588537@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14543 Modified Files: ChangeLog Log Message: Date: Sun Sep 18 18:25:16 2005 Author: wjenkner Index: slime/ChangeLog diff -u slime/ChangeLog:1.782 slime/ChangeLog:1.783 --- slime/ChangeLog:1.782 Sun Sep 18 16:36:01 2005 +++ slime/ChangeLog Sun Sep 18 18:25:16 2005 @@ -1,3 +1,8 @@ +2005-09-18 Wolfgang Jenkner + + * bridge.el: cl is required at macro expansion time (because of + `block'). Reported by Matthew D Swank. + 2005-09-18 Matthias Koeppe * swank.lisp: Move presentation menu protocol here from present.lisp. From heller at common-lisp.net Sun Sep 18 21:06:32 2005 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Sep 2005 23:06:32 +0200 (CEST) Subject: [slime-cvs] CVS update: Directory change: slime/swank-scheme48 Message-ID: <20050918210632.4F0D488537@common-lisp.net> Update of /project/slime/cvsroot/slime/swank-scheme48 In directory common-lisp.net:/tmp/cvs-serv1946/swank-scheme48 Log Message: Directory /project/slime/cvsroot/slime/swank-scheme48 added to the repository Date: Sun Sep 18 23:06:31 2005 Author: heller New directory slime/swank-scheme48 added From heller at common-lisp.net Sun Sep 18 21:10:25 2005 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Sep 2005 23:10:25 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-scheme48/README slime/swank-scheme48/continuation.scm slime/swank-scheme48/defrectype*.scm slime/swank-scheme48/inspector.scm slime/swank-scheme48/interfaces.scm slime/swank-scheme48/io.scm slime/swank-scheme48/load.scm slime/swank-scheme48/module.scm slime/swank-scheme48/packages.scm slime/swank-scheme48/repl.scm slime/swank-scheme48/restart.scm slime/swank-scheme48/session.scm slime/swank-scheme48/sldb.scm slime/swank-scheme48/tcp-server.scm slime/swank-scheme48/top.scm slime/swank-scheme48/weak.scm slime/swank-scheme48/world.scm slime/swank-scheme48/xvector.scm Message-ID: <20050918211025.886F688537@common-lisp.net> Update of /project/slime/cvsroot/slime/swank-scheme48 In directory common-lisp.net:/tmp/cvs-serv1986 Added Files: README continuation.scm defrectype*.scm inspector.scm interfaces.scm io.scm load.scm module.scm packages.scm repl.scm restart.scm session.scm sldb.scm tcp-server.scm top.scm weak.scm world.scm xvector.scm Log Message: New backend for Scheme48 from Taylor Campbell. Date: Sun Sep 18 23:10:21 2005 Author: heller From heller at common-lisp.net Sun Sep 18 21:13:05 2005 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Sep 2005 23:13:05 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050918211305.4D98388537@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv2067 Modified Files: slime.el Log Message: (slime48): New Command. Date: Sun Sep 18 23:13:04 2005 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.548 slime/slime.el:1.549 --- slime/slime.el:1.548 Fri Sep 16 05:43:08 2005 +++ slime/slime.el Sun Sep 18 23:13:04 2005 @@ -1274,6 +1274,23 @@ (slime-dispatching-connection process)) (slime-setup-connection process symbolic-lisp-name))) +(defun slime48 () + "Start a Scheme48 process and connect to its Swank server." + (interactive) + (setq-default slime-lisp-package:connlocal "(scratch)") + (setq-default slime-lisp-package-prompt-string:connlocal "(scratch)") + (let ((proc (slime-start-lisp + scheme-program-name (get-buffer-create "*inferior-lisp*") + (concat ",translate =slime48/ " slime-path "swank-scheme48/\n" + ",exec ,load =slime48/load.scm\n" + ",exec " + (format "(slime48-start %S)" (slime-swank-port-file)) + "\n")))) + (switch-to-buffer (process-buffer proc)) + (goto-char (point-max)) + (slime-read-port-and-connect proc nil))) + + (defun slime-start-and-load (filename &optional package) "Start Slime, if needed, load the current file and set the package." (interactive (list (expand-file-name (buffer-file-name)) From heller at common-lisp.net Sun Sep 18 21:16:53 2005 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Sep 2005 23:16:53 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050918211653.6046F88537@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv2938 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Sep 18 23:16:51 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.783 slime/ChangeLog:1.784 --- slime/ChangeLog:1.783 Sun Sep 18 18:25:16 2005 +++ slime/ChangeLog Sun Sep 18 23:16:51 2005 @@ -1,3 +1,11 @@ +2005-09-19 Helmut Eller + + * slime.el (slime48): New command. + +2005-09-19 Taylor Campbell + + * swank-scheme48/: New backend. + 2005-09-18 Wolfgang Jenkner * bridge.el: cl is required at macro expansion time (because of From lgorrie at common-lisp.net Mon Sep 19 08:20:49 2005 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 19 Sep 2005 10:20:49 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/nregex.lisp slime/ChangeLog Message-ID: <20050919082049.AFDF388031@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16746 Modified Files: nregex.lisp ChangeLog Log Message: Released into the public domain by Lawrence E. Freil. Date: Mon Sep 19 10:20:48 2005 Author: lgorrie Index: slime/nregex.lisp diff -u slime/nregex.lisp:1.3 slime/nregex.lisp:1.4 --- slime/nregex.lisp:1.3 Fri Jun 10 19:54:00 2005 +++ slime/nregex.lisp Mon Sep 19 10:20:48 2005 @@ -1,13 +1,12 @@ ;;; ;;; This code was written by: ;;; -;;; Lawrence E. Freil +;;; Lawrence E. Freil ;;; National Science Center Foundation ;;; Augusta, Georgia 30909 ;;; -;;; If you modify this code, please comment your modifications -;;; clearly and inform the author of any improvements so they -;;; can be incorporated in future releases. +;;; This program was released into the public domain on 2005-08-31. +;;; (See the slime-devel mailing list archive for details.) ;;; ;;; nregex.lisp - My 4/8/92 attempt at a Lisp based regular expression ;;; parser. Index: slime/ChangeLog diff -u slime/ChangeLog:1.784 slime/ChangeLog:1.785 --- slime/ChangeLog:1.784 Sun Sep 18 23:16:51 2005 +++ slime/ChangeLog Mon Sep 19 10:20:48 2005 @@ -1,3 +1,7 @@ +2005-09-19 Luke Gorrie + + * nregex.lisp: Released into the public domain by Lawrence E. Freil. + 2005-09-19 Helmut Eller * slime.el (slime48): New command. From heller at common-lisp.net Wed Sep 21 11:39:11 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 21 Sep 2005 13:39:11 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-gray.lisp Message-ID: <20050921113911.BCBAB8815C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7817 Modified Files: swank-gray.lisp Log Message: Improve stream efficiency by buffering more output. stream-force-output simply does nothing, if the output buffer was flushed less than 200 millisecons before. stream-finish-output can still be used to really flush the buffer. (slime-output-stream): New slot last-flush-time. (stream-finish-output): New function. Did was stream-force-output did previously. (stream-force-output): Buffer more output. Date: Wed Sep 21 13:39:11 2005 Author: heller Index: slime/swank-gray.lisp diff -u slime/swank-gray.lisp:1.7 slime/swank-gray.lisp:1.8 --- slime/swank-gray.lisp:1.7 Wed Jan 19 19:28:37 2005 +++ slime/swank-gray.lisp Wed Sep 21 13:39:10 2005 @@ -12,9 +12,10 @@ (defclass slime-output-stream (fundamental-character-output-stream) ((output-fn :initarg :output-fn) - (buffer :initform (make-string 512)) + (buffer :initform (make-string 8000)) (fill-pointer :initform 0) - (column :initform 0))) + (column :initform 0) + (last-flush-time :initform (get-internal-real-time)))) (defmethod stream-write-char ((stream slime-output-stream) char) (with-slots (buffer fill-pointer column) stream @@ -22,9 +23,10 @@ (incf fill-pointer) (incf column) (when (char= #\newline char) - (setf column 0)) + (setf column 0) + (force-output stream)) (when (= fill-pointer (length buffer)) - (force-output stream))) + (finish-output stream))) char) (defmethod stream-line-column ((stream slime-output-stream)) @@ -33,12 +35,22 @@ (defmethod stream-line-length ((stream slime-output-stream)) 75) -(defmethod stream-force-output ((stream slime-output-stream)) - (with-slots (buffer fill-pointer output-fn) stream +(defmethod stream-finish-output ((stream slime-output-stream)) + (with-slots (buffer fill-pointer output-fn last-flush-time) stream (let ((end fill-pointer)) (unless (zerop end) (funcall output-fn (subseq buffer 0 end)) - (setf fill-pointer 0)))) + (setf fill-pointer 0))) + (setf last-flush-time (get-internal-real-time))) + nil) + +(defmethod stream-force-output ((stream slime-output-stream)) + (with-slots (last-flush-time) stream + (let ((now (get-internal-real-time))) + (when (> (/ (- now last-flush-time) + (coerce internal-time-units-per-second 'double-float)) + 0.2) + (finish-output stream)))) nil) (defclass slime-input-stream (fundamental-character-input-stream) @@ -50,7 +62,7 @@ (with-slots (buffer index output-stream input-fn) s (when (= index (length buffer)) (when output-stream - (force-output output-stream)) + (finish-output output-stream)) (let ((string (funcall input-fn))) (cond ((zerop (length string)) (return-from stream-read-char :eof)) From heller at common-lisp.net Wed Sep 21 11:40:09 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 21 Sep 2005 13:40:09 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: <20050921114009.157AE8815C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7847 Modified Files: swank-cmucl.lisp Log Message: Improve stream efficiency by buffering more output. stream-force-output simply does nothing, if the output buffer was flushed less than 200 millisecons before. stream-finish-output can still be used to really flush the buffer. (slime-output-stream): New slot last-flush-time. (stream-finish-output): New function. Did was stream-force-output did previously. (stream-force-output): Buffer more output. Date: Wed Sep 21 13:40:08 2005 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.153 slime/swank-cmucl.lisp:1.154 --- slime/swank-cmucl.lisp:1.153 Mon Sep 5 15:56:37 2005 +++ slime/swank-cmucl.lisp Wed Sep 21 13:40:08 2005 @@ -156,9 +156,7 @@ (defimplementation add-fd-handler (socket fn) (let ((fd (socket-fd socket))) - (sys:add-fd-handler fd :input (lambda (_) - _ - (funcall fn))))) + (sys:add-fd-handler fd :input (lambda (_) _ (funcall fn))))) (defimplementation remove-fd-handlers (socket) (sys:invalidate-descriptor (socket-fd socket))) @@ -181,9 +179,11 @@ (:print-function %print-slime-output-stream) (:constructor make-slime-output-stream (output-fn))) (output-fn nil :type function) - (buffer (make-string 512) :type string) + (buffer (make-string 8000) :type string) (index 0 :type kernel:index) - (column 0 :type kernel:index)) + (column 0 :type kernel:index) + (last-flush-time (get-internal-real-time) :type unsigned-byte) + ) (defun %print-slime-output-stream (s stream d) (declare (ignore d)) @@ -199,22 +199,44 @@ (setf (sos.column stream) 0) (force-output stream)) (when (= index (1- (length buffer))) - (force-output stream))) + (finish-output stream))) char) (defun sos/sout (stream string start end) (loop for i from start below end do (sos/out stream (aref string i)))) +(defun log-stream-op (stream operation) + stream operation + #+(or) + (progn + (format sys:*tty* "~S @ ~D ~A~%" operation + (sos.index stream) + (/ (- (get-internal-real-time) (sos.last-flush-time stream)) + (coerce internal-time-units-per-second 'double-float))) + (finish-output sys:*tty*))) + (defun sos/misc (stream operation &optional arg1 arg2) (declare (ignore arg1 arg2)) (case operation - ((:force-output :finish-output) + (:finish-output + (log-stream-op stream operation) (let ((end (sos.index stream))) (unless (zerop end) (let ((s (subseq (sos.buffer stream) 0 end))) (setf (sos.index stream) 0) - (funcall (sos.output-fn stream) s))))) + (funcall (sos.output-fn stream) s))) + (setf (sos.last-flush-time stream) (get-internal-real-time))) + nil) + (:force-output + (log-stream-op stream operation) + (let ((last (sos.last-flush-time stream)) + (now (get-internal-real-time))) + (when (> (/ (- now last) + (coerce internal-time-units-per-second 'double-float)) + 0.2) + (finish-output stream))) + nil) (:charpos (sos.column stream)) (:line-length 75) (:file-position nil) From heller at common-lisp.net Wed Sep 21 11:41:52 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 21 Sep 2005 13:41:52 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050921114152.86C508815C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7870 Modified Files: swank.lisp Log Message: (make-output-function): Rename :read-output to :write-string. (eval-for-emacs, interactive-eval, eval-region): Use finish-output not force-output. Date: Wed Sep 21 13:41:51 2005 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.338 slime/swank.lisp:1.339 --- slime/swank.lisp:1.338 Sun Sep 18 16:34:31 2005 +++ slime/swank.lisp Wed Sep 21 13:41:51 2005 @@ -458,7 +458,7 @@ (with-connection (connection) (with-simple-restart (abort "Abort sending output to Emacs.") - (send-to-emacs `(:read-output ,string))))) + (send-to-emacs `(:write-string ,string))))) nil))) (defun open-dedicated-output-stream (socket-io external-format) @@ -600,9 +600,9 @@ (encode-message `(:eval ,(thread-id thread) , at args) socket-io)) ((:emacs-return thread-id tag value) (send (find-thread thread-id) `(take-input ,tag ,value))) - (((:read-output :presentation-start :presentation-end - :new-package :new-features :ed :%apply :indentation-update - :eval-no-wait :background-message) + (((:write-string :presentation-start :presentation-end + :new-package :new-features :ed :%apply :indentation-update + :eval-no-wait :background-message) &rest _) (declare (ignore _)) (encode-message event socket-io)))) @@ -720,10 +720,10 @@ ((:return thread &rest args) (declare (ignore thread)) (send `(:return , at args))) - (((:read-output :new-package :new-features :debug-condition - :presentation-start :presentation-end - :indentation-update :ed :%apply :eval-no-wait - :background-message) + (((:write-string :new-package :new-features :debug-condition + :presentation-start :presentation-end + :indentation-update :ed :%apply :eval-no-wait + :background-message) &rest _) (declare (ignore _)) (send event))))) @@ -1059,16 +1059,19 @@ (lisp-implementation-version) (machine-instance))) -(defslimefun io-speed-test (n m) - (let ((s *standard-output*) - (*trace-output* *log-output*)) +(defslimefun io-speed-test (&optional (n 5000) (m 1)) + (let* ((s *standard-output*) + (*trace-output* (make-broadcast-stream s *log-output*))) (time (progn (dotimes (i n) (format s "~D abcdefghijklm~%" i) (when (zerop (mod n m)) - (finish-output s))) + (force-output s))) (finish-output s) - (eval-in-emacs '(message "done.")))) + (when *emacs-connection* + (eval-in-emacs '(message "done."))))) + (terpri *trace-output*) + (finish-output *trace-output*) nil)) @@ -1759,7 +1762,7 @@ (check-type *buffer-package* package) (check-type *buffer-readtable* readtable) (setq result (eval form)) - (force-output) + (finish-output) (run-hook *pre-reply-hook*) (setq ok t)) (force-user-output) @@ -1784,7 +1787,7 @@ (with-buffer-syntax () (let ((values (multiple-value-list (eval (from-string string))))) (fresh-line) - (force-output) + (finish-output) (format-values-for-echo-area values)))) (defslimefun eval-and-grab-output (string) @@ -1838,13 +1841,13 @@ (let ((form (read stream nil stream))) (when (eq form stream) (fresh-line) - (force-output) + (finish-output) (return (values values -))) (setq - form) (if *slime-repl-eval-hooks* (setq values (run-repl-eval-hooks form)) (setq values (multiple-value-list (eval form)))) - (force-output))))) + (finish-output))))) (when (and package-update-p (not (eq *package* *buffer-package*))) (send-to-emacs (list :new-package (package-name *package*) From heller at common-lisp.net Wed Sep 21 11:43:51 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 21 Sep 2005 13:43:51 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-allegro.lisp slime/swank-lispworks.lisp slime/swank-openmcl.lisp slime/swank-ecl.lisp Message-ID: <20050921114351.078718815C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7905 Modified Files: swank-allegro.lisp swank-lispworks.lisp swank-openmcl.lisp swank-ecl.lisp Log Message: Import `stream-finish-output'. Date: Wed Sep 21 13:43:48 2005 Author: heller Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.75 slime/swank-allegro.lisp:1.76 --- slime/swank-allegro.lisp:1.75 Thu Jul 14 11:12:02 2005 +++ slime/swank-allegro.lisp Wed Sep 21 13:43:47 2005 @@ -18,6 +18,7 @@ '(excl:fundamental-character-output-stream excl:stream-write-char excl:stream-force-output + excl:stream-finish-output excl:fundamental-character-input-stream excl:stream-read-char excl:stream-listen Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.77 slime/swank-lispworks.lisp:1.78 --- slime/swank-lispworks.lisp:1.77 Mon Aug 29 23:29:24 2005 +++ slime/swank-lispworks.lisp Wed Sep 21 13:43:47 2005 @@ -17,6 +17,7 @@ '(stream:fundamental-character-output-stream stream:stream-write-char stream:stream-force-output + stream:stream-finish-output stream:fundamental-character-input-stream stream:stream-read-char stream:stream-listen Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.100 slime/swank-openmcl.lisp:1.101 --- slime/swank-openmcl.lisp:1.100 Tue Sep 13 07:37:16 2005 +++ slime/swank-openmcl.lisp Wed Sep 21 13:43:47 2005 @@ -57,6 +57,7 @@ ccl:stream-write-char ccl:stream-line-length ccl:stream-force-output + ccl:stream-finish-output ccl:fundamental-character-input-stream ccl:stream-read-char ccl:stream-listen Index: slime/swank-ecl.lisp diff -u slime/swank-ecl.lisp:1.1 slime/swank-ecl.lisp:1.2 --- slime/swank-ecl.lisp:1.1 Wed Aug 3 11:40:19 2005 +++ slime/swank-ecl.lisp Wed Sep 21 13:43:47 2005 @@ -11,6 +11,7 @@ ext::stream-write-char ext::stream-line-length ext::stream-force-output + ext::stream-finish-output ext::fundamental-character-input-stream ext::stream-read-char ext::stream-listen From heller at common-lisp.net Wed Sep 21 11:44:33 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 21 Sep 2005 13:44:33 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-scheme48/io.scm Message-ID: <20050921114433.163F18815C@common-lisp.net> Update of /project/slime/cvsroot/slime/swank-scheme48 In directory common-lisp.net:/tmp/cvs-serv7956 Modified Files: io.scm Log Message: (empty-swank-output-buffer): Rename :read-output to :write-string. Date: Wed Sep 21 13:44:32 2005 Author: heller Index: slime/swank-scheme48/io.scm diff -u slime/swank-scheme48/io.scm:1.1 slime/swank-scheme48/io.scm:1.2 --- slime/swank-scheme48/io.scm:1.1 Sun Sep 18 23:10:21 2005 +++ slime/swank-scheme48/io.scm Wed Sep 21 13:44:32 2005 @@ -41,7 +41,7 @@ (if (maybe-commit) (begin (send-outgoing-swank-message (placeholder-value (port-data port)) - `(:READ-OUTPUT ,string)) + `(:WRITE-STRING ,string)) #t) #f))) From heller at common-lisp.net Wed Sep 21 11:45:13 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 21 Sep 2005 13:45:13 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-scheme48/load.scm Message-ID: <20050921114513.DC0E98815C@common-lisp.net> Update of /project/slime/cvsroot/slime/swank-scheme48 In directory common-lisp.net:/tmp/cvs-serv8185 Modified Files: load.scm Log Message: (slime48-start): Fix '() vs. #f bug. Date: Wed Sep 21 13:45:12 2005 Author: heller Index: slime/swank-scheme48/load.scm diff -u slime/swank-scheme48/load.scm:1.1 slime/swank-scheme48/load.scm:1.2 --- slime/swank-scheme48/load.scm:1.1 Sun Sep 18 23:10:21 2005 +++ slime/swank-scheme48/load.scm Wed Sep 21 13:45:12 2005 @@ -73,9 +73,9 @@ (in 'slime48 (lambda () (call-with-values (lambda () - (eval (if port-file - `(start-swank , at port-file) - '(slime48)) + (eval (if (null? port-file) + '(slime48) + `(start-swank , at port-file)) (interaction-environment))) (lambda (world server) (user (lambda () From heller at common-lisp.net Wed Sep 21 11:50:23 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 21 Sep 2005 13:50:23 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050921115023.7348E8815C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9005 Modified Files: slime.el Log Message: (slime-io-speed-test): New command. (slime-process-available-input): Oops, don't start a timer for every event. (slime-write-string): Renamed from slime-output-string. (slime-dispatch-event): Rename :read-output to :write-string. (slime-open-stream-to-lisp): Fix parens. The coding system should also be set if presentations are disabled. Date: Wed Sep 21 13:50:22 2005 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.549 slime/slime.el:1.550 --- slime/slime.el:1.549 Sun Sep 18 23:13:04 2005 +++ slime/slime.el Wed Sep 21 13:50:22 2005 @@ -373,7 +373,7 @@ ;; mouseable text sucks in Emacs 20 nil) (t t)) - "Should we enable presentations" + "*Should we enable presentations" :type '(boolean) :group 'slime-repl) @@ -1712,10 +1712,14 @@ (slime-net-close process t) (error "net-read error: %S" error))))) (slime-log-event event) - (unwind-protect - (save-current-buffer (slime-dispatch-event event process)) - (when (slime-net-have-input-p) - (slime-run-when-idle 'slime-process-available-input process))))))) + (let ((ok nil)) + (unwind-protect + (save-current-buffer + (slime-dispatch-event event process) + (setq ok t)) + (unless ok + (slime-run-when-idle + 'slime-process-available-input process)))))))) (defun slime-net-have-input-p () "Return true if a complete message is available." @@ -2302,8 +2306,8 @@ (defun slime-dispatch-event (event &optional process) (let ((slime-dispatching-connection (or process (slime-connection)))) (destructure-case event - ((:read-output output) - (slime-output-string output)) + ((:write-string output) + (slime-write-string output)) ((:presentation-start id) (slime-mark-presentation-start id)) ((:presentation-end id) @@ -2548,7 +2552,7 @@ (defun slime-show-last-output () "Show the output from the last Lisp evaluation." (with-current-buffer (slime-output-buffer) - (slime-flush-output) + ;;(slime-flush-output) (let ((start slime-output-start) (end slime-output-end)) (funcall slime-show-last-output-function start end)))) @@ -2588,7 +2592,7 @@ (with-current-buffer (process-buffer process) (when (and (plusp (length string)) (eq (process-status slime-buffer-connection) 'open)) - (slime-output-string string)))) + (slime-write-string string)))) ;; FIXME: This conditional is not right - just used because the code ;; here does not work in XEmacs. @@ -2705,17 +2709,44 @@ (install-bridge) (setq bridge-destination-insert nil) (setq bridge-source-insert nil) - (setq bridge-handlers (list* '("<" . slime-mark-presentation-start-handler) - '(">" . slime-mark-presentation-end-handler) - bridge-handlers)) - (set-process-coding-system stream - slime-net-coding-system - slime-net-coding-system)) + (setq bridge-handlers + (list* '("<" . slime-mark-presentation-start-handler) + '(">" . slime-mark-presentation-end-handler) + bridge-handlers))) + (set-process-coding-system stream + slime-net-coding-system + slime-net-coding-system) (when-let (secret (slime-secret)) (slime-net-send secret stream)) stream)) -(defun slime-output-string (string) +(defun slime-io-speed-test (&optional profile) + "A simple minded benchmark for stream performance. +If a prefix argument is given, instrument the slime package for +profiling before running the benchmark." + (interactive "P") + (eval-and-compile + (require 'elp)) + (elp-reset-all) + (elp-restore-all) + (load "slime.el") + ;;(byte-compile-file "slime-net.el" t) + ;;(setq slime-log-events nil) + (setq slime-enable-evaluate-in-emacs t) + (setq slime-repl-enable-presentations nil) + (when profile + (elp-instrument-package "slime-")) + (kill-buffer (slime-output-buffer)) + ;;(display-buffer (slime-output-buffer)) + (delete-other-windows) + (sit-for 0) + (slime-repl-send-string "(swank:io-speed-test 5000 1)") + (let ((proc (slime-inferior-process))) + (when proc + (switch-to-buffer (process-buffer proc)) + (goto-char (point-max))))) + +(defun slime-write-string (string) (with-current-buffer (slime-output-buffer) (slime-with-output-end-mark (slime-propertize-region '(face slime-repl-output-face) @@ -4541,7 +4572,7 @@ (let ((location (slime-note.location note))) (when location (destructure-case location - ((:error msg) ) ; do nothing + ((:error _) _ nil) ; do nothing ((:location file pos _hints) (cond ((eq (car file) ':source-form) nil) (t @@ -7453,7 +7484,7 @@ (let* ((number (sldb-frame-number-at-point))) (slime-eval-async `(swank:eval-string-in-frame ,string ,number) (if current-prefix-arg - 'slime-output-string + 'slime-write-string 'slime-display-eval-result)))) (defun sldb-pprint-eval-in-frame (string) @@ -7680,7 +7711,7 @@ (interactive) (when (null sldb-condition) (error "No condition known (wrong buffer?)")) - (slime-output-string (format "%s\n%s\n" + (slime-write-string (format "%s\n%s\n" (first sldb-condition) (second sldb-condition)))) @@ -9628,7 +9659,7 @@ '(slime-alistify slime-log-event slime-events-buffer - slime-output-string + slime-write-string slime-output-buffer slime-connection-output-buffer slime-output-filter From heller at common-lisp.net Wed Sep 21 11:53:27 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 21 Sep 2005 13:53:27 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050921115327.47E208815C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9047 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Sep 21 13:53:26 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.785 slime/ChangeLog:1.786 --- slime/ChangeLog:1.785 Mon Sep 19 10:20:48 2005 +++ slime/ChangeLog Wed Sep 21 13:53:26 2005 @@ -1,3 +1,35 @@ +2005-09-21 Helmut Eller + + * swank-gray.lisp, swank-cmucl.lisp: Improve stream efficiency by + buffering more output. stream-force-output simply does nothing, if + the output buffer was flushed less than 200 millisecons before. + stream-finish-output can still be used to really flush the buffer. + (slime-output-stream): New slot last-flush-time. + (stream-finish-output): New function. Do what stream-force-output + did previously. + (stream-force-output): Buffer more output. + + * slime.el (slime-process-available-input): Oops, don't start a + timer for every event. + (slime-write-string): Renamed from slime-output-string. + (slime-dispatch-event): Rename :read-output to :write-string. + (slime-io-speed-test): New command. + (slime-open-stream-to-lisp): Fix parens. The coding system should + also be set if presentations are disabled. + + * swank.lisp (make-output-function): Rename :read-output to + :write-string. + (eval-for-emacs, interactive-eval, eval-region): Use finish-output + not force-output. + + * swank-sbcl.lisp, swank-openmcl.lisp, swank-allegro.lisp, + swank-lispworks: Import `stream-finish-output'. + + * swank-scheme48/io.scm (empty-swank-output-buffer): Rename + :read-output to :write-string. + + * swank-scheme48/load.scm (slime48-start): Fix '() vs. #f bug. + 2005-09-19 Luke Gorrie * nregex.lisp: Released into the public domain by Lawrence E. Freil. From heller at common-lisp.net Wed Sep 21 20:34:08 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 21 Sep 2005 22:34:08 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/present.lisp Message-ID: <20050921203408.1154788597@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12965 Modified Files: present.lisp Log Message: (presentation-start, presentation-end): Use finish-output instead of force-output. Date: Wed Sep 21 22:33:59 2005 Author: heller Index: slime/present.lisp diff -u slime/present.lisp:1.16 slime/present.lisp:1.17 --- slime/present.lisp:1.16 Sun Sep 18 16:35:02 2005 +++ slime/present.lisp Wed Sep 21 22:33:46 2005 @@ -115,7 +115,7 @@ (prin1 pid stream) (write-string "" stream)) (t - (force-output stream) + (finish-output stream) (send-to-emacs `(:presentation-start ,pid))))) (setf (presentation-record-printed-p record) t))) @@ -129,7 +129,7 @@ (prin1 pid stream) (write-string "" stream)) (t - (force-output stream) + (finish-output stream) (send-to-emacs `(:presentation-end ,pid))))))) (defun presenting-object-1 (object stream continue) From heller at common-lisp.net Wed Sep 21 20:44:56 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 21 Sep 2005 22:44:56 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050921204456.D83E88859A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13168 Modified Files: swank.lisp Log Message: (throw-to-toplevel): Invoke the `abort-restart' request instead of throwing to the `slime-toplevel' catch tag. (handle-request): Rename the restart from abort to abort-request. (call-with-connection): Remove the slime-toplevel catch tag because with-connection is used in far to many places which aren't at "toplevel". Date: Wed Sep 21 22:44:26 2005 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.339 slime/swank.lisp:1.340 --- slime/swank.lisp:1.339 Wed Sep 21 13:41:51 2005 +++ slime/swank.lisp Wed Sep 21 22:43:17 2005 @@ -278,10 +278,9 @@ (defun call-with-connection (connection fun) (let ((*emacs-connection* connection)) - (catch 'slime-toplevel - (with-io-redirection (*emacs-connection*) - (let ((*debugger-hook* #'swank-debugger-hook)) - (funcall fun)))))) + (with-io-redirection (*emacs-connection*) + (let ((*debugger-hook* #'swank-debugger-hook)) + (funcall fun))))) (defmacro without-interrupts (&body body) `(call-without-interrupts (lambda () , at body))) @@ -479,7 +478,7 @@ (let ((*swank-state-stack* '(:handle-request)) (*debugger-hook* nil)) (with-connection (connection) - (with-simple-restart (abort "Abort handling SLIME request.") + (with-simple-restart (abort-request "Abort handling SLIME request.") (read-from-emacs))))) (defun current-socket-io () @@ -2174,12 +2173,15 @@ (continue)) (defslimefun throw-to-toplevel () - "Use THROW to abort an RPC from Emacs. + "Invoke the ABORT-REQUEST restart abort an RPC from Emacs. If we are not evaluating an RPC then ABORT instead." - (ignore-errors (throw 'slime-toplevel nil)) - ;; If we get here then there was no catch. Try aborting as a fallback. - ;; That makes the 'q' command in SLDB safer to use with threads. - (abort)) + (let ((restart (find-restart 'abort-request))) + (cond (restart (invoke-restart restart)) + (t + ;; If we get here then there was no catch. Try aborting as + ;; a fallback. That makes the 'q' command in SLDB safer to + ;; use with threads. + (abort))))) (defslimefun invoke-nth-restart-for-emacs (sldb-level n) "Invoke the Nth available restart. From heller at common-lisp.net Wed Sep 21 20:50:42 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 21 Sep 2005 22:50:42 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050921205042.307AE885A9@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13524 Modified Files: slime.el Log Message: (slime-setup-command-hooks): Make after-change-functions a buffer-local variable; it's by default global in XEmacs. Date: Wed Sep 21 22:50:41 2005 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.550 slime/slime.el:1.551 --- slime/slime.el:1.550 Wed Sep 21 13:50:22 2005 +++ slime/slime.el Wed Sep 21 22:50:40 2005 @@ -896,6 +896,7 @@ (add-hook 'pre-command-hook 'slime-pre-command-hook nil t) (add-hook 'post-command-hook 'slime-post-command-hook nil t) (when slime-repl-enable-presentations + (make-local-variable 'after-change-functions) (add-hook 'after-change-functions 'slime-after-change-function nil t))) @@ -2733,7 +2734,7 @@ ;;(byte-compile-file "slime-net.el" t) ;;(setq slime-log-events nil) (setq slime-enable-evaluate-in-emacs t) - (setq slime-repl-enable-presentations nil) + ;;(setq slime-repl-enable-presentations nil) (when profile (elp-instrument-package "slime-")) (kill-buffer (slime-output-buffer)) @@ -8823,6 +8824,8 @@ (cond ((time-less-p end (current-time)) (error "Timeout waiting for condition: %S" name)) (t + ;; XXX if a process-filter enters a recursive-edit, we + ;; hang forever (accept-process-output nil 0 100000)))))) (defun slime-sync-to-top-level (timeout) @@ -9184,8 +9187,8 @@ (insert input) (call-interactively 'slime-repl-return) (slime-sync-to-top-level 5) - (slime-check "Buffer contains result" - (equal result-contents (buffer-string))))) + (slime-test-expect "Buffer contains result" + result-contents (buffer-string)))) (def-slime-test repl-read-lines (command inputs final-contents) @@ -9236,15 +9239,17 @@ () "Test if BREAK invokes SLDB." '(()) + (slime-check-top-level) (slime-compile-string (prin1-to-string '(cl:defun cl-user::foo () (cl:break))) 0) + (slime-sync-to-top-level 2) (slime-eval-async '(cl-user::foo)) (slime-wait-condition "Debugger visible" (lambda () (and (slime-sldb-level= 1) (get-buffer-window (sldb-get-default-buffer)))) - 10) + 5) (with-current-buffer (sldb-get-default-buffer) (sldb-quit)) (slime-sync-to-top-level 5)) From heller at common-lisp.net Wed Sep 21 20:54:14 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 21 Sep 2005 22:54:14 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: <20050921205414.03C55885A9@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13944 Modified Files: swank-sbcl.lisp Log Message: Import `stream-finish-output'. Date: Wed Sep 21 22:54:13 2005 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.144 slime/swank-sbcl.lisp:1.145 --- slime/swank-sbcl.lisp:1.144 Tue Sep 13 00:58:17 2005 +++ slime/swank-sbcl.lisp Wed Sep 21 22:54:08 2005 @@ -24,6 +24,7 @@ sb-gray:stream-write-char sb-gray:stream-line-length sb-gray:stream-force-output + sb-gray:stream-finish-output sb-gray:fundamental-character-input-stream sb-gray:stream-read-char sb-gray:stream-listen From heller at common-lisp.net Wed Sep 21 20:55:51 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 21 Sep 2005 22:55:51 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050921205551.92B3B8859A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13984 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Sep 21 22:55:50 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.786 slime/ChangeLog:1.787 --- slime/ChangeLog:1.786 Wed Sep 21 13:53:26 2005 +++ slime/ChangeLog Wed Sep 21 22:55:50 2005 @@ -1,5 +1,19 @@ 2005-09-21 Helmut Eller + * slime.el (slime-setup-command-hooks): Make + after-change-functions a buffer-local variable; it's by default + global in XEmacs. + + * swank.lisp (throw-to-toplevel): Invoke the `abort-restart' + request instead of throwing to the `slime-toplevel' catch tag. + (handle-request): Rename the restart from abort to abort-request. + (call-with-connection): Remove the slime-toplevel catch tag + because with-connection is used in far to many places which aren't + at "toplevel". + + * present.lisp (presentation-start, presentation-end): Use + finish-output instead of force-output. + * swank-gray.lisp, swank-cmucl.lisp: Improve stream efficiency by buffering more output. stream-force-output simply does nothing, if the output buffer was flushed less than 200 millisecons before. From heller at common-lisp.net Thu Sep 22 20:15:13 2005 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 22 Sep 2005 22:15:13 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-gray.lisp Message-ID: <20050922201513.6E314880E6@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16834 Modified Files: swank-gray.lisp Log Message: (stream-fresh-line): Define a method, so that Allegro passes our tests. Date: Thu Sep 22 22:15:12 2005 Author: heller Index: slime/swank-gray.lisp diff -u slime/swank-gray.lisp:1.8 slime/swank-gray.lisp:1.9 --- slime/swank-gray.lisp:1.8 Wed Sep 21 13:39:10 2005 +++ slime/swank-gray.lisp Thu Sep 22 22:15:11 2005 @@ -45,13 +45,18 @@ nil) (defmethod stream-force-output ((stream slime-output-stream)) - (with-slots (last-flush-time) stream + (with-slots (last-flush-time fill-pointer) stream (let ((now (get-internal-real-time))) (when (> (/ (- now last-flush-time) (coerce internal-time-units-per-second 'double-float)) 0.2) (finish-output stream)))) nil) + +(defmethod stream-fresh-line ((stream slime-output-stream)) + (with-slots (column) stream + (cond ((zerop column) nil) + (t (terpri stream) t)))) (defclass slime-input-stream (fundamental-character-input-stream) ((output-stream :initarg :output-stream) From heller at common-lisp.net Thu Sep 22 20:17:33 2005 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 22 Sep 2005 22:17:33 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-backend.lisp Message-ID: <20050922201733.61977880E6@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17623 Modified Files: swank-backend.lisp Log Message: (*gray-stream-symbols*): Collect the needed symbols here, so that we don't need to mention them in every backend. (import-from). New function. Date: Thu Sep 22 22:17:32 2005 Author: heller Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.87 slime/swank-backend.lisp:1.88 --- slime/swank-backend.lisp:1.87 Sun Aug 28 16:47:11 2005 +++ slime/swank-backend.lisp Thu Sep 22 22:17:32 2005 @@ -155,6 +155,27 @@ (import real-symbol :swank-mop) (export real-symbol :swank-mop))))) +(defvar *gray-stream-symbols* + '(:fundamental-character-output-stream + :stream-write-char + :stream-fresh-line + :stream-force-output + :stream-finish-output + :fundamental-character-input-stream + :stream-read-char + :stream-listen + :stream-unread-char + :stream-clear-input + :stream-line-column + :stream-read-char-no-hang)) + +(defun import-from (package symbol-names &optional (to-package *package*)) + "Import the list of SYMBOL-NAMES found in the package PACKAGE." + (dolist (name symbol-names) + (multiple-value-bind (symbol found) (find-symbol (string name) package) + (assert found () "Symbol ~A not found in package ~A" name package) + (import symbol to-package)))) + ;;;; Utilities From heller at common-lisp.net Thu Sep 22 20:20:45 2005 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 22 Sep 2005 22:20:45 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp slime/swank-allegro.lisp slime/swank-lispworks.lisp slime/swank-openmcl.lisp slime/swank-ecl.lisp Message-ID: <20050922202045.3CF90880E6@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17666 Modified Files: swank-sbcl.lisp swank-allegro.lisp swank-lispworks.lisp swank-openmcl.lisp swank-ecl.lisp Log Message: Use *gray-stream-symbols* instead of enumerating them in each backend. Date: Thu Sep 22 22:20:43 2005 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.145 slime/swank-sbcl.lisp:1.146 --- slime/swank-sbcl.lisp:1.145 Wed Sep 21 22:54:08 2005 +++ slime/swank-sbcl.lisp Thu Sep 22 22:20:43 2005 @@ -11,27 +11,16 @@ ;;; Administrivia +(in-package :swank-backend) + (eval-when (:compile-toplevel :load-toplevel :execute) (require 'sb-bsd-sockets) (require 'sb-introspect) (require 'sb-posix)) -(in-package :swank-backend) (declaim (optimize (debug 2))) -(import - '(sb-gray:fundamental-character-output-stream - sb-gray:stream-write-char - sb-gray:stream-line-length - sb-gray:stream-force-output - sb-gray:stream-finish-output - sb-gray:fundamental-character-input-stream - sb-gray:stream-read-char - sb-gray:stream-listen - sb-gray:stream-unread-char - sb-gray:stream-clear-input - sb-gray:stream-line-column - sb-gray:stream-line-length)) +(import-from :sb-gray *gray-stream-symbols* :swank-backend) ;;; swank-mop Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.76 slime/swank-allegro.lisp:1.77 --- slime/swank-allegro.lisp:1.76 Wed Sep 21 13:43:47 2005 +++ slime/swank-allegro.lisp Thu Sep 22 22:20:43 2005 @@ -14,18 +14,7 @@ (require :sock) (require :process) - (import - '(excl:fundamental-character-output-stream - excl:stream-write-char - excl:stream-force-output - excl:stream-finish-output - excl:fundamental-character-input-stream - excl:stream-read-char - excl:stream-listen - excl:stream-unread-char - excl:stream-clear-input - excl:stream-line-column - excl:stream-read-char-no-hang))) + (import-from :excl *gray-stream-symbols* :swank-backend)) ;;; swank-mop Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.78 slime/swank-lispworks.lisp:1.79 --- slime/swank-lispworks.lisp:1.78 Wed Sep 21 13:43:47 2005 +++ slime/swank-lispworks.lisp Thu Sep 22 22:20:43 2005 @@ -11,20 +11,8 @@ (in-package :swank-backend) (eval-when (:compile-toplevel :load-toplevel :execute) - (require "comm")) - -(import - '(stream:fundamental-character-output-stream - stream:stream-write-char - stream:stream-force-output - stream:stream-finish-output - stream:fundamental-character-input-stream - stream:stream-read-char - stream:stream-listen - stream:stream-unread-char - stream:stream-clear-input - stream:stream-line-column - )) + (require "comm") + (import-from :stream *gray-stream-symbols* :swank-backend)) (import-swank-mop-symbols :clos '(:slot-definition-documentation :eql-specializer Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.101 slime/swank-openmcl.lisp:1.102 --- slime/swank-openmcl.lisp:1.101 Wed Sep 21 13:43:47 2005 +++ slime/swank-openmcl.lisp Thu Sep 22 22:20:43 2005 @@ -52,19 +52,7 @@ (in-package :swank-backend) -(import - '(ccl:fundamental-character-output-stream - ccl:stream-write-char - ccl:stream-line-length - ccl:stream-force-output - ccl:stream-finish-output - ccl:fundamental-character-input-stream - ccl:stream-read-char - ccl:stream-listen - ccl:stream-unread-char - ccl:stream-clear-input - ccl:stream-line-column - ccl:stream-line-length)) +(import-from :ccl *gray-stream-symbols* :swank-backend) (require 'xref) Index: slime/swank-ecl.lisp diff -u slime/swank-ecl.lisp:1.2 slime/swank-ecl.lisp:1.3 --- slime/swank-ecl.lisp:1.2 Wed Sep 21 13:43:47 2005 +++ slime/swank-ecl.lisp Thu Sep 22 22:20:43 2005 @@ -6,19 +6,7 @@ (in-package :swank-backend) -(import - '(ext::fundamental-character-output-stream - ext::stream-write-char - ext::stream-line-length - ext::stream-force-output - ext::stream-finish-output - ext::fundamental-character-input-stream - ext::stream-read-char - ext::stream-listen - ext::stream-unread-char - ext::stream-clear-input - ext::stream-line-column - ext::stream-line-length)) +(import-from :ext *gray-stream-symbols* :swank-backend) (swank-backend::import-swank-mop-symbols :clos '(:eql-specializer From heller at common-lisp.net Thu Sep 22 20:23:44 2005 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 22 Sep 2005 22:23:44 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050922202344.E0D91880E6@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17723 Modified Files: swank.lisp Log Message: (accept-authenticated-connection): Minor fix. Ensure that the decoded message is a string before calling string= on it. Patch from Aleksandar Bakic. Date: Thu Sep 22 22:23:43 2005 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.340 slime/swank.lisp:1.341 --- slime/swank.lisp:1.340 Wed Sep 21 22:43:17 2005 +++ slime/swank.lisp Thu Sep 22 22:23:42 2005 @@ -393,9 +393,10 @@ (let ((new (apply #'accept-connection args)) (secret (slime-secret))) (when secret - (unless (string= (decode-message new) secret) - (close new) - (error "Incoming connection doesn't know the password."))) + (let ((first-val (decode-message new))) + (unless (and (stringp first-val) (string= first-val secret)) + (close new) + (error "Incoming connection doesn't know the password.")))) new)) (defun slime-secret () From heller at common-lisp.net Thu Sep 22 20:27:05 2005 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 22 Sep 2005 22:27:05 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050922202705.5D796880E6@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17775 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Thu Sep 22 22:27:04 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.787 slime/ChangeLog:1.788 --- slime/ChangeLog:1.787 Wed Sep 21 22:55:50 2005 +++ slime/ChangeLog Thu Sep 22 22:27:04 2005 @@ -1,3 +1,22 @@ +2005-09-22 Helmut Eller + + * swank-backend.lisp (*gray-stream-symbols*): Collect the needed + symbols here, so that we don't need to mention them in every + backend. + (import-from). New function. + + * swank-sbcl.lisp, swank-allegro.lisp, swank-lispworks.lisp, + swank-openmcl.lisp, swank-ecl.lisp: Use *gray-stream-symbols* when + importing the needed symbols. + + * swank-gray.lisp (stream-fresh-line): Define a method, so that + Allegro passes our tests. + +2005-09-21 Aleksandar Bakic + + * swank.lisp (accept-authenticated-connection): Minor fix. Ensure + that the decoded message is a string before calling string= on it. + 2005-09-21 Helmut Eller * slime.el (slime-setup-command-hooks): Make From heller at common-lisp.net Tue Sep 27 21:50:41 2005 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 27 Sep 2005 23:50:41 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-backend.lisp slime/swank-lispworks.lisp slime/swank-cmucl.lisp slime/swank-allegro.lisp Message-ID: <20050927215041.7389788558@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7264 Modified Files: swank-backend.lisp swank-lispworks.lisp swank-cmucl.lisp swank-allegro.lisp Log Message: (startup-multiprocessing): Deleted. (initialize-multiprocessing, startup-idle-and-top-level-loops): The replacements for startup-multiprocessing. startup-idle-and-top-level-loops is only needed for CMUCL, but initialize-multiprocessing is useful for other too. Date: Tue Sep 27 23:50:39 2005 Author: heller Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.88 slime/swank-backend.lisp:1.89 --- slime/swank-backend.lisp:1.88 Thu Sep 22 22:17:32 2005 +++ slime/swank-backend.lisp Tue Sep 27 23:50:38 2005 @@ -745,10 +745,12 @@ ;;; The default implementations are sufficient for non-multiprocessing ;;; implementations. -(definterface startup-multiprocessing () - "Initialize multiprocessing, if necessary. +(definterface initialize-multiprocessing () + "Initialize multiprocessing, if necessary." + nil) -This function is called directly through the listener, not in an RPC +(definterface startup-idle-and-top-level-loops () + "This function is called directly through the listener, not in an RPC from Emacs. This is to support interfaces such as CMUCL's MP::STARTUP-IDLE-AND-TOP-LEVEL-LOOPS which does not return like a normal function." Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.79 slime/swank-lispworks.lisp:1.80 --- slime/swank-lispworks.lisp:1.79 Thu Sep 22 22:20:43 2005 +++ slime/swank-lispworks.lisp Tue Sep 27 23:50:38 2005 @@ -676,7 +676,7 @@ ;;; Multithreading -(defimplementation startup-multiprocessing () +(defimplementation initialize-multiprocessing () (mp:initialize-multiprocessing)) (defimplementation spawn (fn &key name) Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.154 slime/swank-cmucl.lisp:1.155 --- slime/swank-cmucl.lisp:1.154 Wed Sep 21 13:40:08 2005 +++ slime/swank-cmucl.lisp Tue Sep 27 23:50:38 2005 @@ -182,8 +182,7 @@ (buffer (make-string 8000) :type string) (index 0 :type kernel:index) (column 0 :type kernel:index) - (last-flush-time (get-internal-real-time) :type unsigned-byte) - ) + (last-flush-time (get-internal-real-time) :type unsigned-byte)) (defun %print-slime-output-stream (s stream d) (declare (ignore d)) @@ -225,17 +224,21 @@ (unless (zerop end) (let ((s (subseq (sos.buffer stream) 0 end))) (setf (sos.index stream) 0) - (funcall (sos.output-fn stream) s))) - (setf (sos.last-flush-time stream) (get-internal-real-time))) + (funcall (sos.output-fn stream) s)) + (setf (sos.last-flush-time stream) (get-internal-real-time)))) nil) (:force-output (log-stream-op stream operation) - (let ((last (sos.last-flush-time stream)) - (now (get-internal-real-time))) + (unless (or (zerop (sos.index stream)) + (loop with buffer = (sos.buffer stream) + for i from 0 below (sos.index stream) + always (char= (aref buffer i) #\newline))) + (let ((last (sos.last-flush-time stream)) + (now (get-internal-real-time))) (when (> (/ (- now last) (coerce internal-time-units-per-second 'double-float)) - 0.2) - (finish-output stream))) + 0.1) + (finish-output stream)))) nil) (:charpos (sos.column stream)) (:line-length 75) @@ -2009,7 +2012,10 @@ #+mp (progn - (defimplementation startup-multiprocessing () + (defimplementation initialize-multiprocessing () + (mp::init-multi-processing)) + + (defimplementation startup-idle-and-top-level-loops () ;; Threads magic: this never returns! But top-level becomes ;; available again. (mp::startup-idle-and-top-level-loops)) Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.77 slime/swank-allegro.lisp:1.78 --- slime/swank-allegro.lisp:1.77 Thu Sep 22 22:20:43 2005 +++ slime/swank-allegro.lisp Tue Sep 27 23:50:38 2005 @@ -518,7 +518,7 @@ ;;;; Multithreading -(defimplementation startup-multiprocessing () +(defimplementation initialize-multiprocessing () (mp:start-scheduler)) (defimplementation spawn (fn &key name) From heller at common-lisp.net Tue Sep 27 21:55:05 2005 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 27 Sep 2005 23:55:05 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-scheme48/defrectype*.scm Message-ID: <20050927215505.DFDCB88558@common-lisp.net> Update of /project/slime/cvsroot/slime/swank-scheme48 In directory common-lisp.net:/tmp/cvs-serv7317 Removed Files: defrectype*.scm Log Message: rename the file. Windows doesn't like * in filenames. Date: Tue Sep 27 23:55:05 2005 Author: heller From heller at common-lisp.net Tue Sep 27 21:55:49 2005 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 27 Sep 2005 23:55:49 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-scheme48/defrectypeX.scm Message-ID: <20050927215549.0555A88558@common-lisp.net> Update of /project/slime/cvsroot/slime/swank-scheme48 In directory common-lisp.net:/tmp/cvs-serv7360 Added Files: defrectypeX.scm Log Message: renamed the file. Date: Tue Sep 27 23:55:49 2005 Author: heller From heller at common-lisp.net Tue Sep 27 22:13:30 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 28 Sep 2005 00:13:30 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-scheme48/source-location.scm slime/swank-scheme48/completion.scm slime/swank-scheme48/module.scm slime/swank-scheme48/interfaces.scm slime/swank-scheme48/inspector.scm slime/swank-scheme48/load.scm slime/swank-scheme48/packages.scm Message-ID: <20050927221330.9CE3588558@common-lisp.net> Update of /project/slime/cvsroot/slime/swank-scheme48 In directory common-lisp.net:/tmp/cvs-serv8853 Modified Files: module.scm interfaces.scm inspector.scm load.scm packages.scm Added Files: source-location.scm completion.scm Log Message: * swank-scheme48/source-location.scm: New file. For M-. * swank-scheme48/module.scm (list-all-package): New function. * swank-scheme48/interfaces.scm (module-control-interface): Export it. * swank-scheme48/inspector.scm: Add methods for records and and hashtables. (swank:arglist-for-echo-area): Implement it. Only works for functions with enough debug-data (ie. only user-defined functions). * swank-scheme48/completion.scm: New file. (swank:simple-completions, swank:apropos-list-for-emacs): Implemented. * swank-scheme48/load.scm, swank-scheme48/defrectypeX.scm: Renamed the file from defrectype*.scm * swank-scheme48/packages.scm (swank-general-rpc): Don't use posix-process because it doesn't work on Windows, and we don't need it for a mulithreaded server. Date: Wed Sep 28 00:13:28 2005 Author: heller Index: slime/swank-scheme48/module.scm diff -u slime/swank-scheme48/module.scm:1.1 slime/swank-scheme48/module.scm:1.2 --- slime/swank-scheme48/module.scm:1.1 Sun Sep 18 23:10:21 2005 +++ slime/swank-scheme48/module.scm Wed Sep 28 00:13:28 2005 @@ -140,3 +140,14 @@ (warn "can't undefine inherited binding")) (else (warn "can't undefine nonexistent binding"))))) + + + +;;; Heap groveling + +;; Return a list of all known packages. +(define (list-all-packages) + (vector->list (find-all-records :package))) + +;; The package record-type. Only needed for find-all-records. +(define :package (record-type (interaction-environment))) Index: slime/swank-scheme48/interfaces.scm diff -u slime/swank-scheme48/interfaces.scm:1.1 slime/swank-scheme48/interfaces.scm:1.2 --- slime/swank-scheme48/interfaces.scm:1.1 Sun Sep 18 23:10:21 2005 +++ slime/swank-scheme48/interfaces.scm Wed Sep 28 00:13:28 2005 @@ -56,7 +56,7 @@ current-swank-session current-swank-world - current-swank-return-tag + current-swank-return-tag push-swank-level pop-swank-level @@ -173,10 +173,13 @@ swank:inspector-next swank:quit-inspector swank:describe-inspectee + swank:inspector-reinspect + + swank:arglist-for-echo-area )) (define-interface swank-arglist-rpc-interface - (export swank:arglist-for-echo-area + (export ;;swank:arglist-for-echo-area swank:variable-desc-for-echo-area swank:arglist-for-insertion swank:complete-form @@ -188,6 +191,8 @@ swank:fuzzy-completions swank:fuzzy-completion-selected swank:list-all-package-names + + swank:apropos-list-for-emacs )) (define-interface swank-definition-finding-rpc-interface @@ -207,6 +212,7 @@ fold-config-structures config-structure-names config-package-names + list-all-packages maybe-environment-ref maybe-structure-ref package-reflective-tower Index: slime/swank-scheme48/inspector.scm diff -u slime/swank-scheme48/inspector.scm:1.1 slime/swank-scheme48/inspector.scm:1.2 --- slime/swank-scheme48/inspector.scm:1.1 Sun Sep 18 23:10:21 2005 +++ slime/swank-scheme48/inspector.scm Wed Sep 28 00:13:28 2005 @@ -90,6 +90,9 @@ (set-current-inspector! #f) 'nil) +(define (swank:inspector-reinspect) + (reinspect-object)) + (define (inspect-object obj) (set-current-inspector! (make-inspector obj)) (reinspect-object)) @@ -118,7 +121,7 @@ (process-inspector-listing listing) (set-current-inspector-parts! parts) `(:TITLE ,title - :TYPE ,(string-upcase (symbol->string type)) + :TYPE ,(symbol->string type) :CONTENT ,contents)))) (define (process-inspector-listing listing) @@ -202,7 +205,10 @@ (define-method &inspect-object ((loc :location)) (values "A location (top-level variable cell)." 'location - `("Contents: " (,(contents loc))))) + `("Contents: " (,(contents loc)) #\newline + "id: " (,(location-id loc)) #\newline + "assigned?: " (,(location-assigned? loc)) #\newline + "defined?: " (,(location-defined? loc)) #\newline))) (define-method &inspect-object ((cell :cell)) (values "A cell." @@ -216,6 +222,60 @@ 'weak-pointer `("Ref: " (,(weak-pointer-ref weak))))) +(define-method &inspect-object ((r :record)) + (let ((type (record-type r)) + (len (record-length r))) + (values "A record." + (record-type-name type) + `(,@(let loop ((i 1) + (ns (record-type-field-names type))) + (cond ((= i len) '()) + (else + `(,(symbol->string (car ns)) + ": " + (,(record-ref r i)) #\newline + ,@(loop (+ i 1) (cdr ns)))))) + ;;#\newline type (,type) #\newline + )))) + +(define-simple-type :table (:record) table?) + +(define-method &inspect-object ((t :table)) + (values "A table." + (record-type-name (record-type t)) + `("size: " ,(number->string (table-size t)) #\newline #\newline + ,@(let ((result '())) + (table-walk + (lambda (key value) + (set! result (append `((,key) ": " (,value) #\newline) + result))) + t) + result)))) + +(define-method &inspect-object ((p :closure)) + (values "A closure." + 'closure + `("env: " (,(closure-env p)) #\newline + "template: " (,(closure-template p)) #\newline))) + +(define-method &inspect-object ((t :template)) + (values "A template (compiled code)." 'template + `("code: " (,(template-code t)) #\newline + "byte-code: " (,(template-byte-code t)) #\newline + "info: " (,(template-info t)) #\newline + "package-id: " (,(template-package-id t)) #\newline + ,@(build-indexed-inspector-listing + t template-ref template-length (lambda (t i) #f)) + #\newline #\newline + "disassembly:" #\newline #\newline ,(disassemble-to-string t) + ))) + +(define (disassemble-to-string template) + (call-with-string-output-port + (lambda (port) + (call-with-current-output-port + port (lambda () (disassemble template)))))) + ;;; Numbers @@ -264,27 +324,33 @@ unassigned?) (define-method &inspect-object ((obj :type)) (values title type-id - (let ((len (length obj))) - `("Length: " (,len) ,newline - "Contents:" ,newline - ,@(reduce ((count* i 0 len)) - ((items '())) - (append-reverse `(,newline ,i - ,(if (unassigned? obj i) - "{unassigned}" - (list (ref obj i)))) - items) + (build-indexed-inspector-listing obj ref length unassigned?)))) - (reverse items))))))) +(define (build-indexed-inspector-listing object ref length unassigned?) + (let ((len (length object))) + `("Length: " (,len) ,newline + "Contents:" ,newline + ,@(reduce ((count* i 0 len)) + ((items '())) + (append-reverse `(,newline ,i + ,(if (unassigned? object i) + "{unassigned}" + (list (ref object i)))) + items) + (reverse items))))) (define-indexed-inspector :vector "A vector." 'vector vector-ref vector-length vector-unassigned?) ; may be the case in environments -(define-indexed-inspector :template "A template (compiled code)." - 'template - template-ref template-length - (lambda (t i) #f)) +(define-simple-type :byte-vector (:value) byte-vector?) +(define-simple-type :code-vector (:value) code-vector?) + +(define-indexed-inspector :code-vector "A code-vector." 'code-vector + code-vector-ref code-vector-length (lambda (v i) #f)) + +(define-indexed-inspector :byte-vector "A byte-vector." 'byte-vector + byte-vector-ref byte-vector-length (lambda (v i) #f)) @@ -301,7 +367,7 @@ 'proper-list `("Length: " (1) ,newline "Contents:" ,newline - 0 ,(car pair) ,newline))) + 0 (,(car pair)) ,newline))) ((pair? (cdr pair)) (inspect-list pair)) (else @@ -393,7 +459,34 @@ ;;; General compound data +;;; + +(define (swank:arglist-for-echo-area names) + (let* ((name (car names)) + (value (ignore-errors (lambda () + (eval (read-from-string name) + (interaction-environment)))))) + (or (and (procedure? value) + (let ((arglist (procedure-arglist value))) + (and arglist + (format-arglist name arglist)))) + 'nil))) + +(define (format-arglist op args) + (if (null? args) + (string-append "(" op ")") + (string-append "(" op " " (mapconcat symbol->string args " ") ")"))) + +(define (procedure-arglist procedure) + (let ((debug-data (get-debug-data + (template-info + (closure-template procedure))))) + (and debug-data + (let ((env-maps (debug-data-env-maps debug-data))) + (and (pair? env-maps) + (vector->list (vector-ref (car env-maps) 3))))))) + ;;; Random utilities & parameters (define (inspector-depth) 4) @@ -411,3 +504,12 @@ (do ((i 0 (+ i 1))) ((= i len) result) (string-set! result i (char-upcase (string-ref string i)))))) + +(define (mapconcat fun list separator) + (let ((strings (map fun list))) + (cond ((null? strings) "") + (else + (apply string-append + (cons (car strings) + (map (lambda (string) (string-append separator string)) + (cdr strings)))))))) Index: slime/swank-scheme48/load.scm diff -u slime/swank-scheme48/load.scm:1.2 slime/swank-scheme48/load.scm:1.3 --- slime/swank-scheme48/load.scm:1.2 Wed Sep 21 13:45:12 2005 +++ slime/swank-scheme48/load.scm Wed Sep 28 00:13:28 2005 @@ -6,7 +6,7 @@ ;;; This code is written by Taylor Campbell and placed in the Public ;;; Domain. All warranties are disclaimed. -(config '(load "=slime48/defrectype*.scm" +(config '(load "=slime48/defrectypeX.scm" "=slime48/interfaces.scm" "=slime48/packages.scm")) Index: slime/swank-scheme48/packages.scm diff -u slime/swank-scheme48/packages.scm:1.1 slime/swank-scheme48/packages.scm:1.2 --- slime/swank-scheme48/packages.scm:1.1 Sun Sep 18 23:10:21 2005 +++ slime/swank-scheme48/packages.scm Wed Sep 28 00:13:28 2005 @@ -106,7 +106,9 @@ (open scheme formats i/o) ;++ cheesy temporary implementation (begin (define (swank-log fmt . args) - (format (current-noise-port) "~&[Swank: ~?]~%" fmt args)))) + ;;(format (current-noise-port) "~&[Swank: ~?]~%" fmt args) + #t + ))) @@ -117,13 +119,14 @@ (open scheme (subset posix-files (working-directory set-working-directory!)) - (subset posix-process-data (get-process-id)) - (subset posix-processes (process-id->integer)) + ;; doesn't work on Windows + ;;(subset posix-process-data (get-process-id)) + ;;(subset posix-processes (process-id->integer)) swank-sessions ) (optimize auto-integrate) (begin (define (swank:connection-info) - (list (process-id->integer (get-process-id)) + (list 49 ;;(process-id->integer (get-process-id)) "Scheme48" ; Lisp implementation type "scheme48" ; symbolic name for the above '() ; empty features list @@ -214,7 +217,9 @@ receiving destructuring string-i/o + (subset i/o-internal (call-with-current-output-port)) simple-signals + handle xvectors methods reduce ; looping macros @@ -228,6 +233,14 @@ weak cells templates + records + record-types + tables + closures + debug-data + (subset disassembler (disassemble)) + byte-vectors + code-vectors ) (optimize auto-integrate) (files inspector)) @@ -252,33 +265,39 @@ (define-structure swank-completion-rpc swank-completion-rpc-interface (open scheme + big-scheme string-i/o + module-control swank-sessions swank-worlds - ) + packages + packages-internal + bindings + locations + names) (optimize auto-integrate) - (begin (define (swank:completions prefix package) - (list '() prefix)) - (define (swank:simple-completions prefix package) - (list '() prefix)) - (define (swank:fuzzy-completions prefix package) - '()) - (define (swank:fuzzy-completion-selected orig completion) - '()) - (define (swank:list-all-package-names include-nicknames?) - (map write-to-string - (swank-world-package-names (current-swank-world)))) - )) + (files completion)) -(define-structure swank-definition-finding-rpc - swank-definition-finding-rpc-interface - (open scheme) +(define-structure swank-definition-finding-rpc + swank-definition-finding-rpc-interface + (open scheme + big-scheme + handle + string-i/o + module-control + swank-sessions + swank-worlds + packages + packages-internal + bindings + locations + names + filenames + templates + closures + debug-data) (optimize auto-integrate) - (begin (define (swank:find-definitions-for-emacs name) - '()) - (define (swank:buffer-first-change filename) - '()) - )) + (files source-location)) ;;; This macro should go somewhere else. @@ -323,7 +342,8 @@ (subset meta-types (syntax-type)) (subset names (name?)) package-loader - ) + (subset primitives (find-all-records)) + (subset record (record-type))) (optimize auto-integrate) (files module)) From heller at common-lisp.net Tue Sep 27 22:17:50 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 28 Sep 2005 00:17:50 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050927221750.0098288558@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9862 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Sep 28 00:17:50 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.788 slime/ChangeLog:1.789 --- slime/ChangeLog:1.788 Thu Sep 22 22:27:04 2005 +++ slime/ChangeLog Wed Sep 28 00:17:50 2005 @@ -1,3 +1,33 @@ +2005-09-28 Helmut Eller + + * slime.el (slime-multiprocessing): Deleted. No longer needed. + (slime-init-command): Updated accordingly. + (slime-current-package): Add a special case for Scheme. + (slime-simple-completions, slime-apropos): Quote the package, + because in can be a plain symbol in Scheme. + (slime-inspector-reinspect): Use a proper defslimefun. + + * swank.lisp (inspector-reinspect): New function. + (start-server): Call initialize-multiprocessing before starting + the server and startup-idle-and-top-level-loops afterwards. + Calling startup-idle-and-top-level-loops here shouldn't be a + problem because start-server is only invoked at startup via stdin. + + * swank-scheme48/source-location.scm: New file. For M-. + * swank-scheme48/module.scm (list-all-package): New function. + * swank-scheme48/interfaces.scm (module-control-interface): Export it. + * swank-scheme48/inspector.scm: Add methods for records and and + hashtables. + (swank:arglist-for-echo-area): Implement it. Only works for + functions with enough debug-data (ie. only user-defined functions). + * swank-scheme48/completion.scm: New file. + (swank:simple-completions, swank:apropos-list-for-emacs): Implemented. + * swank-scheme48/load.scm, swank-scheme48/defrectypeX.scm: Renamed + the file from defrectype*.scm + * swank-scheme48/packages.scm (swank-general-rpc): Don't use + posix-process because it doesn't work on Windows, and we don't need + it for a mulithreaded server. + 2005-09-22 Helmut Eller * swank-backend.lisp (*gray-stream-symbols*): Collect the needed From heller at common-lisp.net Tue Sep 27 22:42:59 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 28 Sep 2005 00:42:59 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050927224259.361D08855E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11054 Modified Files: slime.el Log Message: (slime-multiprocessing): Deleted. No longer needed. (slime-init-command): Updated accordingly. (slime-current-package): Add a special case for Scheme. (slime-simple-completions, slime-apropos): Quote the package, because in can be a plain symbol in Scheme. (slime-inspector-reinspect): Use a proper defslimefun. Date: Wed Sep 28 00:42:58 2005 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.551 slime/slime.el:1.552 --- slime/slime.el:1.551 Wed Sep 21 22:50:40 2005 +++ slime/slime.el Wed Sep 28 00:42:55 2005 @@ -138,14 +138,6 @@ :prefix "slime-" :group 'slime) -;; XXX How can we get rid of this? I think only CMUCL needs it. -;; -luke (17/Jul/2004) -(defcustom slime-multiprocessing nil - "Instruct the Lisp system to initialize multiprocessing on startup. -You may need to enable this in order to use threads with SLIME." - :type 'boolean - :group 'slime-lisp) - (defcustom slime-backend "swank-loader.lisp" "The name of the Lisp file that loads the Swank server. This name is interpreted relative to the directory containing @@ -1281,17 +1273,16 @@ (setq-default slime-lisp-package:connlocal "(scratch)") (setq-default slime-lisp-package-prompt-string:connlocal "(scratch)") (let ((proc (slime-start-lisp - scheme-program-name (get-buffer-create "*inferior-lisp*") - (concat ",translate =slime48/ " slime-path "swank-scheme48/\n" - ",exec ,load =slime48/load.scm\n" - ",exec " - (format "(slime48-start %S)" (slime-swank-port-file)) - "\n")))) + scheme-program-name (get-buffer-create "*inferior-lisp*") + (concat ",translate =slime48/ " slime-path "swank-scheme48/\n" + ",exec ,load =slime48/load.scm\n" + ",exec " + (format "(slime48-start %S)" (slime-swank-port-file)) + "\n")))) (switch-to-buffer (process-buffer proc)) (goto-char (point-max)) (slime-read-port-and-connect proc nil))) - (defun slime-start-and-load (filename &optional package) "Start Slime, if needed, load the current file and set the package." (interactive (list (expand-file-name (buffer-file-name)) @@ -1409,9 +1400,8 @@ "Return a string to initialize Lisp." (let ((swank (slime-to-lisp-filename (if (file-name-absolute-p slime-backend) slime-backend - (concat slime-path slime-backend)))) - (mp (if slime-multiprocessing "(swank:startup-multiprocessing)\n" ""))) - (format "(load %S :verbose t)\n%s" swank mp))) + (concat slime-path slime-backend))))) + (format "(load %S :verbose t)\n" swank))) (defun slime-start-lisp (command buffername init-string) "Start Lisp with COMMAND in BUFFERNAME and send INIT-STRING to it. @@ -2186,11 +2176,15 @@ search for and read an `in-package' form. The REPL buffer is a special case: it's package is `slime-lisp-package'." - (or (and (eq major-mode 'slime-repl-mode) (slime-lisp-package)) - slime-buffer-package - (save-restriction - (widen) - (slime-find-buffer-package)))) + (cond ((eq major-mode 'slime-repl-mode) + (slime-lisp-package)) + (slime-buffer-package) + ((and (eq major-mode 'scheme-mode) + (boundp 'scheme48-package)) + (symbol-value 'scheme48-package)) + (t (save-restriction + (widen) + (slime-find-buffer-package))))) (defvar slime-find-buffer-package-function nil "Function to use instead of `slime-find-buffer-package'. @@ -3941,6 +3935,7 @@ (defun slime-restart-inferior-lisp-aux () (interactive) + (assert (slime-inferior-process) () "No inferior lisp process") (slime-eval-async '(swank:quit-lisp)) (set-process-filter (slime-connection) nil) (set-process-sentinel (slime-connection) 'slime-restart-sentinel)) @@ -5439,10 +5434,10 @@ (mapcar (lambda (x) (cons x nil)) list)) (defun slime-completions (prefix) - (slime-eval `(swank:completions ,prefix ,(slime-current-package)))) + (slime-eval `(swank:completions ,prefix ',(slime-current-package)))) (defun slime-simple-completions (prefix) - (slime-eval `(swank:simple-completions ,prefix ,(slime-current-package)))) + (slime-eval `(swank:simple-completions ,prefix ',(slime-current-package)))) ;;;; Fuzzy completion @@ -6359,6 +6354,8 @@ (let ((lisp-filename (slime-to-lisp-filename (expand-file-name filename)))) (slime-eval-with-transcript `(swank:load-file ,lisp-filename)))) + + ;;;; Profiling @@ -6468,7 +6465,7 @@ (let ((buffer-package (or package (slime-current-package)))) (slime-eval-async `(swank:apropos-list-for-emacs ,string ,only-external-p - ,case-sensitive-p ,package) + ,case-sensitive-p ',package) (lexical-let ((string string) (package buffer-package) (summary (slime-apropos-summary string case-sensitive-p @@ -8132,7 +8129,7 @@ (defun slime-inspector-reinspect () (interactive) - (slime-eval-async `(swank::inspect-object swank::*inspectee*) 'slime-open-inspector)) + (slime-eval-async `(swank:inspector-reinspect) 'slime-open-inspector)) (slime-define-keys slime-inspector-mode-map ([return] 'slime-inspector-operate-on-point) @@ -9043,7 +9040,7 @@ (slime-check-top-level) (let ((message (current-message))) (slime-check "Minibuffer contains: \"3\"" - (equal "3 (#x3, #o3, #b11)" message)))))) + (equal "=> 3 (#x3, #o3, #b11)" message)))))) (def-slime-test interrupt-bubbling-idiot () @@ -9051,16 +9048,15 @@ '(()) (slime-check-top-level) (slime-eval-async '(cl:loop :for i :from 0 :do (cl:progn (cl:print i) - (cl:force-output))) + (cl:finish-output))) (lambda (_) ) "CL-USER") - (accept-process-output nil 1) (slime-wait-condition "running" #'slime-busy-p 5) (slime-interrupt) (slime-wait-condition "Debugger visible" (lambda () (and (slime-sldb-level= 1) (get-buffer-window (sldb-get-default-buffer)))) - 5) + 20) (with-current-buffer (sldb-get-default-buffer) (sldb-quit)) (slime-sync-to-top-level 5)) @@ -9177,6 +9173,7 @@ \(+ 2 3 4) SWANK> ") ) + (slime-sync-to-top-level 2) (with-current-buffer (slime-output-buffer) (setf (slime-lisp-package-prompt-string) "SWANK")) (kill-buffer (slime-output-buffer)) From heller at common-lisp.net Tue Sep 27 22:44:29 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 28 Sep 2005 00:44:29 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050927224429.DA52B8855E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11090 Modified Files: swank.lisp Log Message: (start-server): Call initialize-multiprocessing before starting the server and startup-idle-and-top-level-loops afterwards. Calling startup-idle-and-top-level-loops here shouldn't be a problem because start-server is only invoked at startup via stdin. (inspector-reinspect): New function. Date: Wed Sep 28 00:44:29 2005 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.341 slime/swank.lisp:1.342 --- slime/swank.lisp:1.341 Thu Sep 22 22:23:42 2005 +++ slime/swank.lisp Wed Sep 28 00:44:28 2005 @@ -341,8 +341,12 @@ dont-close (external-format *coding-system*)) "Start the server and write the listen port number to PORT-FILE. This is the entry point for Emacs." + (when (eq style :spawn) + (initialize-multiprocessing)) (setup-server 0 (lambda (port) (announce-server-port port-file port)) - style dont-close external-format)) + style dont-close external-format) + (when (eq style :spawn) + (startup-idle-and-top-level-loops))) (defun create-server (&key (port default-server-port) (style *communication-style*) @@ -3981,6 +3985,9 @@ (cond ((= (1+ position) (length *inspector-history*)) nil) (t (inspect-object (aref *inspector-history* (1+ position)))))))) + +(defslimefun inspector-reinspect () + (inspect-object *inspectee*)) (defslimefun quit-inspector () (reset-inspector) From lgorrie at common-lisp.net Thu Sep 29 05:15:42 2005 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 29 Sep 2005 07:15:42 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-scheme48/README slime/swank-scheme48/completion.scm slime/swank-scheme48/continuation.scm slime/swank-scheme48/defrectypeX.scm slime/swank-scheme48/inspector.scm slime/swank-scheme48/interfaces.scm slime/swank-scheme48/io.scm slime/swank-scheme48/load.scm slime/swank-scheme48/module.scm slime/swank-scheme48/packages.scm slime/swank-scheme48/repl.scm slime/swank-scheme48/restart.scm slime/swank-scheme48/session.scm slime/swank-scheme48/sldb.scm slime/swank-scheme48/source-location.scm slime/swank-scheme48/tcp-server.scm slime/swank-scheme48/top.scm slime/swank-scheme48/weak.scm slime/swank-scheme48/world.scm slime/swank-scheme48/xvector.scm Message-ID: <20050929051542.391F28855E@common-lisp.net> Update of /project/slime/cvsroot/slime/swank-scheme48 In directory common-lisp.net:/tmp/cvs-serv8553 Removed Files: README completion.scm continuation.scm defrectypeX.scm inspector.scm interfaces.scm io.scm load.scm module.scm packages.scm repl.scm restart.scm session.scm sldb.scm source-location.scm tcp-server.scm top.scm weak.scm world.scm xvector.scm Log Message: Removed due to excessive whining. Date: Thu Sep 29 07:15:27 2005 Author: lgorrie From lgorrie at common-lisp.net Thu Sep 29 05:16:20 2005 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 29 Sep 2005 07:16:20 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050929051620.ABB188855E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9074 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Thu Sep 29 07:16:19 2005 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.789 slime/ChangeLog:1.790 --- slime/ChangeLog:1.789 Wed Sep 28 00:17:50 2005 +++ slime/ChangeLog Thu Sep 29 07:16:19 2005 @@ -1,3 +1,7 @@ +2005-09-29 Luke Gorrie + + * swank-scheme48: Removed due to excessive whining. + 2005-09-28 Helmut Eller * slime.el (slime-multiprocessing): Deleted. No longer needed.