[climacs-cvs] CVS climacs

[crhodes]

Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv25774

Modified Files:
	gui.lisp 
Log Message:
A few bells and whistles:

* add a command argument for kill-buffer, rather than an accept in the 
body;

* when running execute-frame-command, only update syntax etc. when the 
frame argument is also *application-frame*;

* climacs implementations of read-only and modified widgets for the info 
pane.  Ideally that should be ESA functionality, but it didn't look to 
me that the info pane was well factored yet.

* #+sbcl implementation of climacs-as-cl:ed.


--- /project/climacs/cvsroot/climacs/gui.lisp	2006/05/13 17:19:10	1.214
+++ /project/climacs/cvsroot/climacs/gui.lisp	2006/05/14 17:42:21	1.215
@@ -223,6 +223,33 @@
       (clim-sys:make-process #'run :name process-name)
       (run))))
 
+(define-presentation-type read-only ())
+(define-presentation-method highlight-presentation 
+    ((type read-only) record stream state)
+  nil)
+(define-presentation-type modified ())
+(define-presentation-method highlight-presentation 
+    ((type modified) record stream state)
+  nil)
+
+(define-command (com-toggle-read-only :name t :command-table base-table)
+    ((buffer 'buffer))
+  (setf (read-only-p buffer) (not (read-only-p buffer))))
+(define-presentation-to-command-translator toggle-read-only
+    (read-only com-toggle-read-only base-table
+     :gesture :menu)
+    (object)
+  (list object))
+
+(define-command (com-toggle-modified :name t :command-table base-table)
+    ((buffer 'buffer))
+  (setf (needs-saving buffer) (not (needs-saving buffer))))
+(define-presentation-to-command-translator toggle-modified
+    (modified com-toggle-modified base-table
+     :gesture :menu)
+    (object)
+  (list object))
+
 (defun display-info (frame pane)
   (let* ((master-pane (master-pane pane))
 	 (buffer (buffer master-pane))
@@ -230,16 +257,24 @@
 	 (top (top master-pane))
 	 (bot (bot master-pane)))
     (princ "   " pane)
-    (princ (cond ((and (needs-saving buffer)
-		       (read-only-p buffer)
-		       "%*"))
-		 ((needs-saving buffer) "**")
-		 ((read-only-p buffer) "%%")
-		 (t "--"))
-	   pane)
+    (with-output-as-presentation (pane buffer 'read-only)
+      (princ (cond
+               ((read-only-p buffer) "%")
+               ((needs-saving buffer) "*")
+               (t "-"))
+             pane))
+    (with-output-as-presentation (pane buffer 'modified)
+      (princ (cond
+               ((needs-saving buffer) "*")
+               ((read-only-p buffer) "%")
+               (t "-"))
+             pane))
     (princ "  " pane)
     (with-text-face (pane :bold)
-      (format pane "~25A" (name buffer)))
+      (with-output-as-presentation (pane buffer 'buffer)
+        (format pane "~A" (name buffer)))
+      ;; FIXME: bare 25.
+      (format pane "~V at T" (- 25 (length (name buffer)))))
     (format pane "  ~A  "
 	    (cond ((and (mark= size bot)
 			(mark= 0 top))
@@ -305,10 +340,12 @@
         (beep) (display-message "Buffer is read only")))))
 
 (defmethod execute-frame-command :after ((frame climacs) command)
-  (loop for buffer in (buffers frame)
-        do (update-syntax buffer (syntax buffer))
-	do (when (modified-p buffer)
-	     (setf (needs-saving buffer) t))))
+  (when (eq frame *application-frame*)
+    (loop for buffer in (buffers frame)
+          do (when (syntax buffer)
+               (update-syntax buffer (syntax buffer)))
+          do (when (modified-p buffer)
+               (setf (needs-saving buffer) t)))))
 
 (defmethod find-applicable-command-table ((frame climacs))
   (or
@@ -482,19 +519,38 @@
 (defmethod kill-buffer ((symbol (eql 'nil)))
   (kill-buffer (buffer (current-window))))
 
-(define-command (com-kill-buffer :name t :command-table pane-table) ()
+(define-command (com-kill-buffer :name t :command-table pane-table)
+    ((buffer 'buffer
+             :prompt "Kill buffer"
+             :default (buffer (current-window))
+             :default-type 'buffer))
   "Prompt for a buffer name and kill that buffer.
 If the buffer needs saving, will prompt you to do so before killing it. Uses the current buffer as a default."
-  (let ((buffer (accept 'buffer
-			:prompt "Kill buffer"
-			:default (buffer (current-window))
-			:default-type 'buffer)))
-    (kill-buffer buffer)))
+  (kill-buffer buffer))
 
-(set-key 'com-kill-buffer
+(set-key `(com-kill-buffer ,*unsupplied-argument-marker*)
 	 'pane-table
 	 '((#\x :control) (#\k)))
 
+#+sbcl
+(defun ed-in-climacs (thing)
+  (let ((frame-manager (find-frame-manager)))
+    (when frame-manager
+      (let ((climacs-frame (find-if (lambda (x) (typep x 'climacs))
+                                    (frame-manager-frames frame-manager))))
+        (when climacs-frame
+          (typecase thing
+            ((or pathname string)
+             (execute-frame-command 
+              climacs-frame `(com-find-file ,(pathname thing)))
+             t)
+            ((or symbol cons)
+             ;; FIXME: do something
+             nil)))))))
+    
+#+sbcl
+(pushnew 'ed-in-climacs sb-ext:*ed-functions*)
+
 ;;; For the ESA help functions.
 
 (defmethod help-stream ((frame climacs) title)