Commit bd87934a authored by Troels Henriksen's avatar Troels Henriksen

More refactoring of stuff out from CLIMACS-GUI to CLIMACS-CORE and

CLIMACS-COMMANDS. More reusable functions have been moved from the
*-commands.lisp files to core.lisp.
parent b6c15d11
......@@ -97,14 +97,14 @@
(:file "core" :depends-on ("gui"))
(:file "climacs" :depends-on ("gui" "core"))
;; (:file "buffer-commands" :depends-on ("gui"))
(:file "developer-commands" :depends-on ("gui" "lisp-syntax"))
(:file "motion-commands" :depends-on ("gui"))
(:file "editing-commands" :depends-on ("gui"))
(:file "file-commands" :depends-on ("gui"))
(:file "misc-commands" :depends-on ("gui"))
(:file "search-commands" :depends-on ("gui"))
(:file "window-commands" :depends-on ("gui"))
(:file "unicode-commands" :depends-on ("gui"))
(:file "developer-commands" :depends-on ("gui" "lisp-syntax" "core"))
(:file "motion-commands" :depends-on ("gui" "core"))
(:file "editing-commands" :depends-on ("gui" "core"))
(:file "file-commands" :depends-on ("gui" "core"))
(:file "misc-commands" :depends-on ("gui" "core"))
(:file "search-commands" :depends-on ("gui" "core"))
(:file "window-commands" :depends-on ("gui" "core"))
(:file "unicode-commands" :depends-on ("gui" "core"))
(:file "slidemacs" :depends-on ("packages" "buffer" "syntax" "base" "pane" ))
(:file "slidemacs-gui" :depends-on ("packages" "slidemacs" "pane" "buffer" "syntax" "gui"))))
This diff is collapsed.
This diff is collapsed.
......@@ -214,24 +214,6 @@
((type modified) record stream state)
(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)
(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)
(list object))
(defun display-info (frame pane)
(let* ((master-pane (master-pane pane))
(buffer (buffer master-pane))
......@@ -352,27 +334,6 @@ FIXME: does this really have that effect?"
'((#\l :control)))
(defun load-file (file-name)
(cond ((directory-pathname-p file-name)
(display-message "~A is a directory name." file-name)
(cond ((probe-file file-name)
(load file-name))
(display-message "No such file: ~A" file-name)
(define-command (com-load-file :name t :command-table base-table) ()
"Prompt for a filename and CL:LOAD that file.
Signals and error if the file does not exist."
(let ((filepath (accept 'pathname :prompt "Load File")))
(load-file filepath)))
(set-key 'com-load-file
'((#\c :control) (#\l :control)))
(define-command com-self-insert ((count 'integer))
(loop repeat count do (insert-character *current-gesture*)))
......@@ -387,7 +348,7 @@ Signals and error if the file does not exist."
;;; Pane/buffer functions
;;; Pane functions
(defun replace-constellation (constellation additional-constellation vertical-p)
(let* ((parent (sheet-parent constellation))
......@@ -530,12 +491,6 @@ If with-scrollbars nil, omit the scroller."
(list first second other)
(list first other)))))))
(defun make-buffer (&optional name)
(let ((buffer (make-instance 'climacs-buffer)))
(when name (setf (name buffer) name))
(push buffer (buffers *application-frame*))
(defun other-window (&optional pane)
(if (and pane (find pane (windows *application-frame*)))
(setf (windows *application-frame*)
......@@ -550,132 +505,6 @@ If with-scrollbars nil, omit the scroller."
(setf *standard-output* (car (windows *application-frame*)))))
(defgeneric erase-buffer (buffer))
(defmethod erase-buffer ((buffer string))
(let ((b (find buffer (buffers *application-frame*)
:key #'name :test #'string=)))
(when b (erase-buffer b))))
(defmethod erase-buffer ((buffer climacs-buffer))
(let* ((point (point buffer))
(mark (clone-mark point)))
(beginning-of-buffer mark)
(end-of-buffer point)
(delete-region mark point)))
(define-presentation-method present (object (type buffer)
(view textual-view)
&key acceptably for-context-type)
(declare (ignore acceptably for-context-type))
(princ (name object) stream))
(define-presentation-method accept
((type buffer) stream (view textual-view) &key (default nil defaultp)
(default-type type))
(multiple-value-bind (object success string)
(complete-input stream
(lambda (so-far action)
so-far (buffers *application-frame*) '() :action action
:name-key #'name
:value-key #'identity))
:partial-completers '(#\Space)
:allow-any-input t)
(cond (success
(values object type))
((and (zerop (length string)) defaultp)
(values default default-type))
(t (values string 'string)))))
(defgeneric switch-to-buffer (buffer))
(defmethod switch-to-buffer ((buffer climacs-buffer))
(let* ((buffers (buffers *application-frame*))
(position (position buffer buffers))
(pane (current-window)))
(when position
(setf buffers (delete buffer buffers)))
(push buffer (buffers *application-frame*))
(setf (offset (point (buffer pane))) (offset (point pane)))
(setf (buffer pane) buffer)
(full-redisplay pane)
(defmethod switch-to-buffer ((name string))
(let ((buffer (find name (buffers *application-frame*)
:key #'name :test #'string=)))
(switch-to-buffer (or buffer
(make-buffer name)))))
(defmethod switch-to-buffer ((symbol (eql 'nil)))
(let ((default (second (buffers *application-frame*))))
(when default
(switch-to-buffer default))))
;; ;;; FIXME: see the comment by (SETF SYNTAX) :AROUND. -- CSR,
;; ;;; 2005-10-31.
;; (defmethod (setf buffer) :around (buffer (pane extended-pane))
;; (call-next-method)
;; (note-pane-syntax-changed pane (syntax buffer)))
(define-command (com-switch-to-buffer :name t :command-table pane-table) ()
"Prompt for a buffer name and switch to that buffer.
If the a buffer with that name does not exist, create it. Uses the name of the next buffer (if any) as a default."
(let* ((default (second (buffers *application-frame*)))
(buffer (if default
(accept 'buffer
:prompt "Switch to buffer"
:default default)
(accept 'buffer
:prompt "Switch to buffer"))))
(switch-to-buffer buffer)))
(set-key 'com-switch-to-buffer
'((#\x :control) (#\b)))
(defgeneric kill-buffer (buffer))
(defmethod kill-buffer ((buffer climacs-buffer))
(with-slots (buffers) *application-frame*
(when (and (needs-saving buffer)
(handler-case (accept 'boolean :prompt "Save buffer first?")
(error () (progn (beep)
(display-message "Invalid answer")
(return-from kill-buffer nil)))))
(setf buffers (remove buffer buffers))
;; Always need one buffer.
(when (null buffers)
(make-buffer "*scratch*"))
(setf (buffer (current-window)) (car buffers))
(full-redisplay (current-window))
(buffer (current-window))))
(defmethod kill-buffer ((name string))
(let ((buffer (find name (buffers *application-frame*)
:key #'name :test #'string=)))
(when buffer (kill-buffer buffer))))
(defmethod kill-buffer ((symbol (eql 'nil)))
(kill-buffer (buffer (current-window))))
(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."
(kill-buffer buffer))
(set-key `(com-kill-buffer ,*unsupplied-argument-marker*)
'((#\x :control) (#\k)))
;;; For the ESA help functions.
(defmethod help-stream ((frame climacs) title)
......@@ -52,7 +52,7 @@
(make-command-table 'lisp-table
:errorp nil
:inherit-from '(climacs-gui::global-climacs-table))
:inherit-from '(global-climacs-table))
......@@ -97,6 +97,9 @@
(or (slot-value syntax 'base)
(defmethod (setf base) (base (syntax lisp-syntax))
(setf (slot-value syntax 'base) base))
(define-option-for-syntax lisp-syntax "Package" (syntax package-name)
(let ((specified-package (find-package package-name)))
(setf (option-specified-package syntax) (or specified-package package-name))))
......@@ -104,7 +107,9 @@
(define-option-for-syntax lisp-syntax "Base" (syntax base)
(let ((integer-base (parse-integer base :junk-allowed t)))
(when integer-base
(setf (base syntax) integer-base))))
(if (typep integer-base '(integer 2 36))
(setf (base syntax) integer-base)
(esa:display-message "Invalid base specified: outside the interval 2 to 36.")))))
(defmethod initialize-instance :after ((syntax lisp-syntax) &rest args)
(declare (ignore args))
......@@ -3010,7 +3015,7 @@ Each newline and following whitespace is replaced by a single space."
(def-print-for-menu note-compiler-note "Note" +brown+)
(defun show-notes (notes buffer-name definition)
(let ((stream (climacs-gui::typeout-window
(let ((stream (typeout-window
(format nil "~10TCompiler Notes: ~A ~A" buffer-name definition))))
(loop for note in notes
do (with-output-as-presentation (stream note 'compiler-note)
......@@ -3028,33 +3033,27 @@ Each newline and following whitespace is replaced by a single space."
(defmethod goto-location ((location buffer-location))
(let ((buffer (find (buffer-name location)
(climacs-gui::buffers *application-frame*)
(buffers *application-frame*)
:test #'string= :key #'name)))
(unless buffer
(esa:display-message "No buffer ~A" (buffer-name location))
(return-from goto-location))
(climacs-gui::switch-to-buffer buffer)
(switch-to-buffer buffer)
(goto-position (source-position location))))
(defmethod goto-location ((location file-location))
(let ((buffer (find (file-name location)
(climacs-gui::buffers *application-frame*)
(buffers *application-frame*)
:test #'string= :key #'(lambda (buffer)
(let ((path (filepath buffer)))
(when path
(namestring path)))))))
(if buffer
(climacs-gui::switch-to-buffer buffer)
(climacs-gui::find-file (file-name location)))
(switch-to-buffer buffer)
(climacs-commands::find-file (file-name location)))
(goto-position (source-position location))))
(defgeneric goto-position (position))
(defmethod goto-position ((position char-position))
(climacs-gui::goto-position (climacs-gui::point (climacs-gui::current-window))
(char-position position)))
;;; Macroexpansion and evaluation
(defun macroexpand-token (syntax token &optional (all nil))
......@@ -3067,12 +3066,12 @@ Each newline and following whitespace is replaced by a single space."
(expansion-string (with-output-to-string (s)
(pprint expansion s))))
(let ((buffer (climacs-gui::switch-to-buffer "*Macroexpansion*")))
(climacs-gui::set-syntax buffer "Lisp"))
(let ((point (point (climacs-gui::current-window)))
(let ((buffer (switch-to-buffer "*Macroexpansion*")))
(set-syntax buffer "Lisp"))
(let ((point (point (current-window)))
(header-string (one-line-ify (subseq string 0
(min 40 (length string))))))
(climacs-gui::end-of-buffer point)
(end-of-buffer point)
(unless (beginning-of-buffer-p point)
(insert-object point #\Newline))
(insert-sequence point
......@@ -3130,7 +3129,7 @@ results."
(defun compile-file-interactively (buffer &optional load-p)
(when (and (needs-saving buffer)
(accept 'boolean :prompt (format nil "Save buffer ~A ?" (name buffer))))
(climacs-gui::save-buffer buffer))
(save-buffer buffer))
(with-syntax-package (syntax buffer) 0 (package)
(let ((*read-base* (base (syntax buffer))))
(multiple-value-bind (result notes)
......@@ -3745,9 +3744,9 @@ retrieved for the operator, nothing will be displayed."
(let* ((offset+buffer (pop *find-definition-stack*))
(offset (first offset+buffer))
(buffer (second offset+buffer)))
(if (find buffer (climacs-gui::buffers *application-frame*))
(progn (climacs-gui::switch-to-buffer buffer)
(climacs-gui::goto-position (point (climacs-gui::current-window)) offset))
(if (find buffer (buffers *application-frame*))
(progn (switch-to-buffer buffer)
(goto-position (point (current-window)) offset))
;; KLUDGE: We need to put more info in the definition objects to begin
......@@ -3780,7 +3779,7 @@ retrieved for the operator, nothing will be displayed."
(goto-definition symbol definitions))))))
(defun goto-definition (name definitions)
(let* ((pane (climacs-gui:current-window))
(let* ((pane (current-window))
(buffer (buffer pane))
(point (point pane))
(offset (offset point)))
......@@ -3820,7 +3819,7 @@ retrieved for the operator, nothing will be displayed."
(with-drawing-options (stream :ink +dark-blue+
:text-style (make-text-style :fixed nil nil))
(princ (dspec item) stream))))
(let ((stream (climacs-gui::typeout-window
(let ((stream (typeout-window
(format nil "~10T~A ~A" type symbol))))
(loop for xref in xrefs
do (with-output-as-presentation (stream xref 'xref)
......@@ -3938,7 +3937,7 @@ For example:
(defun clear-completions ()
(when *completion-pane*
(climacs-gui::delete-window *completion-pane*)
(delete-window *completion-pane*)
(setf *completion-pane* nil)))
(defun show-completions-by-fn (fn symbol package)
......@@ -3949,7 +3948,7 @@ For example:
(cond ((<=(length set) 1)
(t (let ((stream (or *completion-pane*
(climacs-gui::typeout-window "Simple Completions"))))
(typeout-window "Simple Completions"))))
(setf *completion-pane* stream)
(window-clear stream)
(format stream "~{~A~%~}" set))))
......@@ -3982,7 +3981,7 @@ For example:
(cond ((<= (length set) 1)
(t (let ((stream (or *completion-pane*
(climacs-gui::typeout-window "Simple Completions"))))
(typeout-window "Simple Completions"))))
(setf *completion-pane* stream)
(window-clear stream)
(loop for completed-string in set
......@@ -445,24 +445,6 @@ point at the beginning of the last line of the buffer."
'((#\x :control) (#\x :control)))
(defgeneric set-syntax (buffer syntax))
(defmethod set-syntax ((buffer climacs-buffer) (syntax syntax))
(setf (syntax buffer) syntax))
;;FIXME - what should this specialise on?
(defmethod set-syntax ((buffer climacs-buffer) syntax)
(set-syntax buffer (make-instance syntax :buffer buffer)))
(defmethod set-syntax ((buffer climacs-buffer) (syntax string))
(let ((syntax-class (syntax-from-name syntax)))
(cond (syntax-class
(set-syntax buffer (make-instance syntax-class
:buffer buffer)))
(display-message "No such syntax: ~A." syntax)))))
(define-command (com-set-syntax :name t :command-table buffer-table)
((syntax 'syntax
:prompt "Name of syntax"))
......@@ -88,7 +88,7 @@
(defun beep-limit-action (mark original-offset remaining unit syntax)
(declare (ignore mark original-offset remaining unit syntax))
(defun revert-limit-action (mark original-offset remaining unit syntax)
......@@ -329,16 +329,14 @@
;; Some configuration variables
......@@ -368,8 +366,14 @@
(defpackage :climacs-core
(:use :clim-lisp :climacs-base :climacs-buffer
:climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring
:climacs-editing :climacs-gui :clim :climacs-abbrev)
(:export #:goto-position
:climacs-editing :climacs-gui :clim :climacs-abbrev :esa)
(:export #:display-string
......@@ -384,7 +388,23 @@
#:fill-line #:fill-region
#:indent-line #:delete-indentation)
#:indent-line #:delete-indentation
(:documentation "Package for editor functionality that is
syntax-aware, but yet not specific to certain
syntaxes. Contains stuff like indentation, filling and other
......@@ -424,7 +444,8 @@
(defpackage :climacs-lisp-syntax
(:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base
:climacs-syntax :flexichain :climacs-pane :climacs-gui :climacs-motion :climacs-editing)
:climacs-syntax :flexichain :climacs-pane :climacs-gui
:climacs-motion :climacs-editing :climacs-core)
(:export #:lisp-string
......@@ -28,37 +28,6 @@
(in-package :climacs-commands)
(defun display-string (string)
(with-output-to-string (result)
(loop for char across string
do (cond ((graphic-char-p char) (princ char result))
((char= char #\Space) (princ char result))
(t (prin1 char result))))))
(defun object-equal (x y)
"Case insensitive equality that doesn't require characters"
(if (characterp x)
(and (characterp y) (char-equal x y))
(eql x y)))
(defun object= (x y)
"Case sensitive equality that doesn't require characters"
(if (characterp x)
(and (characterp y) (char= x y))
(eql x y)))
(defun no-upper-p (string)
"Does STRING contain no uppercase characters"
(notany #'upper-case-p string))
(defun case-relevant-test (string)
"Returns a test function based on the search-string STRING.
If STRING contains no uppercase characters the test is case-insensitive,
otherwise it is case-sensitive."
(if (no-upper-p string)
;;; String search
......@@ -530,11 +530,11 @@
(full-redisplay (climacs-gui::current-window)))
(define-command (com-first-talking-point :name t :command-table slidemacs-table) ()
(define-command (com-last-talking-point :name t :command-table slidemacs-table) ()
(define-command (com-flip-slidemacs-syntax :name t :command-table slidemacs-table) ()
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