[climacs-cvs] CVS climacs

[thenriksen]

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

Modified Files:
	climacs-lisp-syntax-commands.lisp climacs.lisp packages.lisp 
	typeout.lisp 
Log Message:
Added code by Rudi Schlatte to integrated Climacs with CL:ED. Only
SBCL is supported for now.


--- /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp	2008/01/21 17:19:34	1.9
+++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp	2008/01/23 18:17:05	1.10
@@ -139,6 +139,11 @@
     (presentation)
     (list (presentation-object presentation)))
 
+(define-command (com-edit-definition :name t :command-table climacs-lisp-table)
+    ((symbol 'symbol))
+  "Edit definition of the symbol."
+  (edit-definition symbol))
+
 (define-command (com-edit-this-definition :command-table climacs-lisp-table)
     ()
   "Edit definition of the symbol at point.
--- /project/climacs/cvsroot/climacs/climacs.lisp	2006/11/12 16:06:06	1.4
+++ /project/climacs/cvsroot/climacs/climacs.lisp	2008/01/23 18:17:05	1.5
@@ -30,21 +30,25 @@
 
 (in-package :climacs)
 
-(defun climacs (&key new-process (process-name "Climacs")
+(defun find-climacs-frame ()
+  (let ((frame-manager (find-frame-manager)))
+    (when frame-manager
+      (find-if (lambda (x) (and (typep x 'climacs) 
+                                (eq (clim:frame-state x) :enabled)))
+               (frame-manager-frames frame-manager)))))
+
+(defun climacs (&rest args &key new-process (process-name "Climacs")
                 (width 900) (height 400))
   "Starts up a climacs session"
-  (let ((frame (make-application-frame 'climacs :width width :height height)))
-    (flet ((run ()
-	     (run-frame-top-level frame)))
-      (if new-process
-	  (clim-sys:make-process #'run :name process-name)
-	  (run)))))
+  (declare (ignore new-process process-name width height))
+  (apply #'climacs-common nil args))
 
-(defun climacs-rv (&key new-process (process-name "Climacs")
-                (width 900) (height 400))
+(defun climacs-rv (&rest args &key new-process (process-name "Climacs")
+                   (width 900) (height 400))
   "Starts up a climacs session with alternative colors."
   ;; SBCL doesn't inherit dynamic bindings when starting new
   ;; processes, so start a new processes and THEN setup the colors.
+  (declare (ignore width height))
   (flet ((run ()
            (let ((*background-color* +black+)
                  (*foreground-color* +gray+)
@@ -52,7 +56,45 @@
                  (*info-fg-color* +gray+)
                  (*mini-bg-color* +black+)
                  (*mini-fg-color* +white+))
-             (climacs :new-process nil :width width :height height))))
+             (apply #'climacs-common nil :new-process nil args))))
     (if new-process
-      (clim-sys:make-process #'run :name process-name)
-      (run))))
+        (clim-sys:make-process #'run :name process-name)
+        (run))))
+
+(defun edit-file (thing &rest args
+                  &key (process-name "Climacs") (width 900) (height 400))
+  "Edit THING in an existing climacs process or start a new one. THING
+can be a filename (edit the file) or symbol (edit its function definition)."
+  (declare (ignore process-name width height))
+  (let ((climacs-frame (find-climacs-frame))
+        (command 
+         (typecase thing
+           (null nil)
+           (symbol (list 'drei-lisp-syntax::com-edit-definition thing))
+           ((or string pathname)
+            (truename thing)  ; raise file-error if file doesn't exist
+            (list 'esa-io::com-find-file thing))
+           (t (error 'type-error :datum thing
+                     :expected-type '(or null string pathname symbol))))))
+    (if climacs-frame
+        (execute-frame-command climacs-frame command)
+        (apply #'climacs-common command :new-process t args)))
+  t)
+
+(defun climacs-common (command &key new-process (process-name "Climacs")
+                       (width 900) (height 400))
+  (let* ((frame (make-application-frame 'climacs :width width :height height))
+         (*application-frame* frame)
+         (esa:*esa-instance* frame))
+    (adopt-frame (find-frame-manager) *application-frame*)
+    (when command (execute-frame-command *application-frame* command))
+    (flet ((run () (run-frame-top-level frame)))
+      (if new-process
+          (clim-sys:make-process #'run :name process-name)
+          (run)))))
+
+;;; Append to end of *ed-functions* so we don't overwrite the user's
+;;; preferred editor
+#+sbcl
+(unless (member 'edit-file sb-ext:*ed-functions*)
+  (setf sb-ext:*ed-functions* (append sb-ext:*ed-functions* (list 'edit-file))))
--- /project/climacs/cvsroot/climacs/packages.lisp	2008/01/21 17:19:34	1.135
+++ /project/climacs/cvsroot/climacs/packages.lisp	2008/01/23 18:17:05	1.136
@@ -199,5 +199,6 @@
   (:use :clim-lisp :clim :clim-sys :clim-extensions :climacs-gui :drei)
   (:export #:climacs
            #:climacs-rv
-           #:edit-definition)
+           #:edit-definition
+           #:edit-file)
   (:documentation "Package containing entry points to Climacs."))
\ No newline at end of file
--- /project/climacs/cvsroot/climacs/typeout.lisp	2008/01/21 17:08:48	1.3
+++ /project/climacs/cvsroot/climacs/typeout.lisp	2008/01/23 18:17:05	1.4
@@ -111,7 +111,7 @@
   "Call `continuation' with a single argument, a
 stream meant for typeout. `Climacs' is the Climacs instance in
 which the typeout pane should be shown, and `label' is the name
-of the created typeout view."
+of the created typeout view. Returns NIL."
   (let* ((typeout-view (ensure-typeout-view climacs label))
          (pane-with-typeout (or (find typeout-view (windows climacs)
                                  :key #'view)
@@ -127,7 +127,8 @@
                           (setf (last-cursor-position typeout-view)
                                 (multiple-value-list (stream-cursor-position pane-with-typeout)))))))
       (add-output-record new-record (output-history typeout-view))
-      (setf (dirty typeout-view) t))))
+      (setf (dirty typeout-view) t)
+      nil)))
 
 (defmacro with-typeout ((stream &optional (label "Typeout")) &body body)
   "Evaluate `body' with `stream' bound to a stream that can be