Commit 9b021d0e authored by Troels Henriksen's avatar Troels Henriksen

Added code by Rudi Schlatte to integrated Climacs with CL:ED. Only

SBCL is supported for now.
parent 4cccf094
......@@ -139,6 +139,11 @@ that file."
(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.
......
......@@ -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))))
......@@ -199,5 +199,6 @@ editing Java(tm) code."))
(: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
......@@ -111,7 +111,7 @@ viewport, do nothing."
"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 @@ of the created typeout view."
(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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment