[slime-cvs] CVS slime
heller
heller at common-lisp.net
Mon Aug 27 12:36:11 UTC 2007
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv8431
Modified Files:
slime.el ChangeLog
Log Message:
Move presentations to contrib. Part I.
* slime.el (slime-event-hooks, slime-dispatch-event): New hook.
(slime-write-string-function, slime-write-string): New hook.
(slime-repl-return-hooks, slime-repl-return): New hook.
(slime-repl-current-input-hooks, slime-repl-current-input): New hook.
(slime-open-stream-hooks, slime-open-stream-to-lisp): New hook.
(sldb-insert-locals, slime-inspector-insert-ispec): Don't use
presentations.
* contrib/slime-presentations.el: New file
--- /project/slime/cvsroot/slime/slime.el 2007/08/26 23:35:25 1.822
+++ /project/slime/cvsroot/slime/slime.el 2007/08/27 12:36:10 1.823
@@ -411,15 +411,6 @@
:type '(character)
:group 'slime-repl)
-(defcustom slime-repl-enable-presentations
- (cond ((and (not (featurep 'xemacs)) (= emacs-major-version 20))
- ;; mouseable text sucks in Emacs 20
- nil)
- (t t))
- "*Should we enable presentations"
- :type '(boolean)
- :group 'slime-repl)
-
(defcustom slime-repl-only-save-lisp-buffers t
"When T we only attempt to save lisp-mode file buffers. When
NIL slime will attempt to save all buffers (as per
@@ -466,20 +457,6 @@
"Face for Lisp output in the SLIME REPL."
:group 'slime-repl)
-
-(defface slime-repl-output-mouseover-face
- (if (featurep 'xemacs)
- '((t (:bold t)))
- (if (slime-face-inheritance-possible-p)
- '((t
- (:box
- (:line-width 1 :color "black" :style released-button)
- :inherit
- slime-repl-inputed-output-face)))
- '((t (:box (:line-width 1 :color "black"))))))
- "Face for Lisp output in the SLIME REPL, when the mouse hovers over it"
- :group 'slime-repl)
-
(defface slime-repl-input-face
'((t (:bold t)))
"Face for previous input in the SLIME REPL."
@@ -490,13 +467,6 @@
"Face for the result of an evaluation in the SLIME REPL."
:group 'slime-repl)
-(defface slime-repl-inputed-output-face
- '((((class color) (background light)) (:foreground "Red"))
- (((class color) (background dark)) (:foreground "Red"))
- (t (:slant italic)))
- "Face for the result of an evaluation in the SLIME REPL."
- :group 'slime-repl)
-
(defcustom slime-repl-history-file "~/.slime-history.eld"
"File to save the persistent REPL history to."
:type 'string
@@ -969,9 +939,7 @@
(defun slime-setup-command-hooks ()
"Setup a buffer-local `pre-command-hook' to call `slime-pre-command-hook'."
(add-local-hook 'pre-command-hook 'slime-pre-command-hook)
- (add-local-hook 'post-command-hook 'slime-post-command-hook)
- (when slime-repl-enable-presentations
- (add-local-hook 'after-change-functions 'slime-after-change-function)))
+ (add-local-hook 'post-command-hook 'slime-post-command-hook))
;;;; Framework'ey bits
@@ -1201,6 +1169,10 @@
(save-excursion (insert-char ?\ column))
(zerop (forward-line -1)))))))
+(defun slime-insert-possibly-as-rectangle (&rest strings)
+ (slime-with-rigid-indentation nil
+ (apply #'insert strings)))
+
;;;;; Snapshots of current Emacs state
;;; Window configurations do not save (and hence not restore)
@@ -2642,79 +2614,77 @@
(slime-def-connection-var slime-continuation-counter 0
"Continuation serial number counter.")
+(defvar slime-event-hooks)
+
(defun slime-dispatch-event (event &optional process)
(let ((slime-dispatching-connection (or process (slime-connection))))
- (destructure-case event
- ((:write-string output &optional id target)
- (slime-write-string output id target))
- ((:presentation-start id &optional target)
- (slime-mark-presentation-start id target))
- ((:presentation-end id &optional target)
- (slime-mark-presentation-end id target))
- ;;
- ((:emacs-rex form package thread continuation)
- (slime-set-state "|eval...")
- (when (and (slime-use-sigint-for-interrupt) (slime-busy-p))
- (message "; pipelined request... %S" form))
- (let ((id (incf (slime-continuation-counter))))
- (push (cons id continuation) (slime-rex-continuations))
- (slime-send `(:emacs-rex ,form ,package ,thread ,id))))
- ((:return value id)
- (let ((rec (assq id (slime-rex-continuations))))
- (cond (rec (setf (slime-rex-continuations)
- (remove rec (slime-rex-continuations)))
- (when (null (slime-rex-continuations))
- (slime-set-state ""))
- (funcall (cdr rec) value))
- (t
- (error "Unexpected reply: %S %S" id value)))))
- ((:debug-activate thread level)
- (assert thread)
- (sldb-activate thread level))
- ((:debug thread level condition restarts frames conts)
- (assert thread)
- (sldb-setup thread level condition restarts frames conts))
- ((:debug-return thread level stepping)
- (assert thread)
- (sldb-exit thread level stepping))
- ((:emacs-interrupt thread)
- (slime-send `(:emacs-interrupt ,thread)))
- ((:read-string thread tag)
- (assert thread)
- (slime-repl-read-string thread tag))
- ((:y-or-n-p thread tag question)
- (slime-y-or-n-p thread tag question))
- ((:read-aborted thread tag)
- (assert thread)
- (slime-repl-abort-read thread tag))
- ((:emacs-return-string thread tag string)
- (slime-send `(:emacs-return-string ,thread ,tag ,string)))
- ;;
- ((:new-package package prompt-string)
- (setf (slime-lisp-package) package)
- (setf (slime-lisp-package-prompt-string) prompt-string))
- ((:new-features features)
- (setf (slime-lisp-features) features))
- ((:indentation-update info)
- (slime-handle-indentation-update info))
- ((:open-dedicated-output-stream port)
- (slime-open-stream-to-lisp port))
- ((:eval-no-wait fun args)
- (apply (intern fun) args))
- ((:eval thread tag form-string)
- (slime-check-eval-in-emacs-enabled)
- (slime-eval-for-lisp thread tag form-string))
- ((:emacs-return thread tag value)
- (slime-send `(:emacs-return ,thread ,tag ,value)))
- ((:ed what)
- (slime-ed what))
- ((:inspect what)
- (slime-open-inspector what))
- ((:background-message message)
- (slime-background-message "%s" message))
- ((:debug-condition thread message)
- (assert thread)
- (message "%s" message)))))
+ (or (run-hook-with-args-until-success 'slime-event-hooks event)
+ (destructure-case event
+ ((:write-string output &optional id target)
+ (slime-write-string output id target))
+ ((:emacs-rex form package thread continuation)
+ (slime-set-state "|eval...")
+ (when (and (slime-use-sigint-for-interrupt) (slime-busy-p))
+ (message "; pipelined request... %S" form))
+ (let ((id (incf (slime-continuation-counter))))
+ (push (cons id continuation) (slime-rex-continuations))
+ (slime-send `(:emacs-rex ,form ,package ,thread ,id))))
+ ((:return value id)
+ (let ((rec (assq id (slime-rex-continuations))))
+ (cond (rec (setf (slime-rex-continuations)
+ (remove rec (slime-rex-continuations)))
+ (when (null (slime-rex-continuations))
+ (slime-set-state ""))
+ (funcall (cdr rec) value))
+ (t
+ (error "Unexpected reply: %S %S" id value)))))
+ ((:debug-activate thread level)
+ (assert thread)
+ (sldb-activate thread level))
+ ((:debug thread level condition restarts frames conts)
+ (assert thread)
+ (sldb-setup thread level condition restarts frames conts))
+ ((:debug-return thread level stepping)
+ (assert thread)
+ (sldb-exit thread level stepping))
+ ((:emacs-interrupt thread)
+ (slime-send `(:emacs-interrupt ,thread)))
+ ((:read-string thread tag)
+ (assert thread)
+ (slime-repl-read-string thread tag))
+ ((:y-or-n-p thread tag question)
+ (slime-y-or-n-p thread tag question))
+ ((:read-aborted thread tag)
+ (assert thread)
+ (slime-repl-abort-read thread tag))
+ ((:emacs-return-string thread tag string)
+ (slime-send `(:emacs-return-string ,thread ,tag ,string)))
+ ;;
+ ((:new-package package prompt-string)
+ (setf (slime-lisp-package) package)
+ (setf (slime-lisp-package-prompt-string) prompt-string))
+ ((:new-features features)
+ (setf (slime-lisp-features) features))
+ ((:indentation-update info)
+ (slime-handle-indentation-update info))
+ ((:open-dedicated-output-stream port)
+ (slime-open-stream-to-lisp port))
+ ((:eval-no-wait fun args)
+ (apply (intern fun) args))
+ ((:eval thread tag form-string)
+ (slime-check-eval-in-emacs-enabled)
+ (slime-eval-for-lisp thread tag form-string))
+ ((:emacs-return thread tag value)
+ (slime-send `(:emacs-return ,thread ,tag ,value)))
+ ((:ed what)
+ (slime-ed what))
+ ((:inspect what)
+ (slime-open-inspector what))
+ ((:background-message message)
+ (slime-background-message "%s" message))
+ ((:debug-condition thread message)
+ (assert thread)
+ (message "%s" message))))))
(defun slime-send (sexp)
"Send SEXP directly over the wire on the current connection."
@@ -2922,145 +2892,7 @@
(eq (process-status slime-buffer-connection) 'open))
(slime-write-string string))))
-;; FIXME: This conditional is not right - just used because the code
-;; here does not work in XEmacs.
-(when slime-repl-enable-presentations
- (when (boundp 'text-property-default-nonsticky)
- (pushnew '(slime-repl-presentation . t) text-property-default-nonsticky
- :test 'equal)
- (pushnew '(slime-repl-result-face . t) text-property-default-nonsticky
- :test 'equal)))
-
-(make-variable-buffer-local
- (defvar slime-presentation-start-to-point (make-hash-table)))
-
-(defun slime-mark-presentation-start (id &optional target)
- "Mark the beginning of a presentation with the given ID.
-TARGET can be nil (regular process output) or :repl-result."
- (setf (gethash id slime-presentation-start-to-point)
- ;; We use markers because text can also be inserted before this presentation.
- ;; (Output arrives while we are writing presentations within REPL results.)
- (copy-marker (slime-output-target-marker target) nil)))
-
-(defun slime-mark-presentation-start-handler (process string)
- (if (and string (string-match "<\\([-0-9]+\\)" string))
- (let* ((match (substring string (match-beginning 1) (match-end 1)))
- (id (car (read-from-string match))))
- (slime-mark-presentation-start id))))
-
-(defun slime-mark-presentation-end (id &optional target)
- "Mark the end of a presentation with the given ID.
-TARGET can be nil (regular process output) or :repl-result."
- (let ((start (gethash id slime-presentation-start-to-point)))
- (remhash id slime-presentation-start-to-point)
- (when start
- (let* ((marker (slime-output-target-marker target))
- (buffer (and marker (marker-buffer marker))))
- (with-current-buffer buffer
- (let ((end (marker-position marker)))
- (slime-add-presentation-properties start end
- id nil)))))))
-
-(defun slime-mark-presentation-end-handler (process string)
- (if (and string (string-match ">\\([-0-9]+\\)" string))
- (let* ((match (substring string (match-beginning 1) (match-end 1)))
- (id (car (read-from-string match))))
- (slime-mark-presentation-end id))))
-
-(defstruct slime-presentation text id)
-
-(defvar slime-presentation-syntax-table
- (let ((table (copy-syntax-table lisp-mode-syntax-table)))
- ;; We give < and > parenthesis syntax, so that #< ... > is treated
- ;; as a balanced expression. This allows to use C-M-k, C-M-SPC,
- ;; etc. to deal with a whole presentation. (For Lisp mode, this
- ;; is not desirable, since we do not wish to get a mismatched
- ;; paren highlighted everytime we type < or >.)
- (modify-syntax-entry ?< "(>" table)
- (modify-syntax-entry ?> ")<" table)
- table)
- "Syntax table for presentations.")
-
-(defun slime-add-presentation-properties (start end id result-p)
- "Make the text between START and END a presentation with ID.
-RESULT-P decides whether a face for a return value or output text is used."
- (let* ((text (buffer-substring-no-properties start end))
- (presentation (make-slime-presentation :text text :id id)))
- (let ((inhibit-modification-hooks t))
- (add-text-properties start end
- `(modification-hooks (slime-after-change-function)
- insert-in-front-hooks (slime-after-change-function)
- insert-behind-hooks (slime-after-change-function)
- syntax-table ,slime-presentation-syntax-table
- rear-nonsticky t))
- ;; Use the presentation as the key of a text property
- (case (- end start)
- (0)
- (1
- (add-text-properties start end
- `(slime-repl-presentation ,presentation
- ,presentation :start-and-end)))
- (t
- (add-text-properties start (1+ start)
- `(slime-repl-presentation ,presentation
- ,presentation :start))
- (when (> (- end start) 2)
- (add-text-properties (1+ start) (1- end)
- `(,presentation :interior)))
- (add-text-properties (1- end) end
- `(slime-repl-presentation ,presentation
- ,presentation :end))))
- ;; Also put an overlay for the face and the mouse-face. This enables
- ;; highlighting of nested presentations. However, overlays get lost
- ;; 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.
- (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 'help-echo
- (if (eq major-mode 'slime-repl-mode)
- "mouse-2: copy to input; mouse-3: menu"
- "mouse-2: inspect; mouse-3: menu"))
- (overlay-put overlay 'face 'slime-repl-inputed-output-face)
- (overlay-put overlay 'keymap slime-presentation-map))))
-
-(defun slime-remove-presentation-properties (from to presentation)
- (let ((inhibit-read-only t))
- (remove-text-properties from to
- `(,presentation t syntax-table 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 'slime-repl-presentation) presentation)
- (delete-overlay overlay)))))
-
-(defun slime-insert-possibly-as-rectangle (&rest strings)
- (slime-with-rigid-indentation nil
- (apply #'insert strings)))
-
-(defun slime-insert-presentation (string output-id &optional rectangle)
- "Insert STRING in current buffer and mark it as a presentation
-corresponding to OUTPUT-ID. If RECTANGLE is true, indent multi-line
-strings to line up below the current point."
- (flet ((insert-it ()
- (if rectangle
- (slime-insert-possibly-as-rectangle string)
- (insert string))))
- (cond ((not slime-repl-enable-presentations)
- (insert-it))
- (t
- (let ((start (point)))
- (insert-it)
- (slime-add-presentation-properties start (point) output-id t))))))
+(defvar slime-open-stream-hooks)
(defun slime-open-stream-to-lisp (port)
(let ((stream (open-network-stream "*lisp-output-stream*"
@@ -3069,21 +2901,11 @@
slime-lisp-host port)))
(slime-set-query-on-exit-flag stream)
(set-process-filter stream 'slime-output-filter)
- (when slime-repl-enable-presentations
- (require 'bridge)
- (defun bridge-insert (process output)
- (slime-output-filter process (or output "")))
- (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)))
(let ((pcs (process-coding-system (slime-current-connection))))
(set-process-coding-system stream (car pcs) (cdr pcs)))
(when-let (secret (slime-secret))
(slime-net-send secret stream))
+ (run-hook-with-args slime-open-stream-hooks stream)
stream))
(defun slime-io-speed-test (&optional profile)
@@ -3112,48 +2934,25 @@
(switch-to-buffer (process-buffer proc))
(goto-char (point-max)))))
-(defvar slime-last-output-target-id 0
- "The last integer we used as a TARGET id.")
[582 lines skipped]
--- /project/slime/cvsroot/slime/ChangeLog 2007/08/26 23:36:43 1.1171
+++ /project/slime/cvsroot/slime/ChangeLog 2007/08/27 12:36:10 1.1172
@@ -1,3 +1,15 @@
+2007-08-27 Helmut Eller <heller at common-lisp.net>
+
+ Move presentations to contrib. Part I.
+
+ * slime.el (slime-event-hooks, slime-dispatch-event): New hook.
+ (slime-write-string-function, slime-write-string): New hook.
+ (slime-repl-return-hooks, slime-repl-return): New hook.
+ (slime-repl-current-input-hooks, slime-repl-current-input): New hook.
+ (slime-open-stream-hooks, slime-open-stream-to-lisp): New hook.
+ (sldb-insert-locals, slime-inspector-insert-ispec): Don't use
+ presentations.
+
2007-08-26 Tobias C. Rittweiler <tcr at freebits.de>
Reduces needless interning of symbols that was introduced by my
More information about the slime-cvs
mailing list