Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv16484
Modified Files:
cl-syntax.lisp climacs.asd climacs.lisp core.lisp
developer-commands.lisp file-commands.lisp groups.lisp
gui.lisp html-syntax.lisp misc-commands.lisp packages.lisp
prolog-syntax.lisp prolog2paiprolog.lisp search-commands.lisp
slidemacs-gui.lisp slidemacs.lisp text-syntax.lisp
ttcn3-syntax.lisp window-commands.lisp
Added Files:
climacs-lisp-syntax-commands.lisp climacs-lisp-syntax.lisp
Log Message:
Make Climacs use Drei. There are known problems (apart from the docs
now being outdated):
* Some syntaxes have not been updated.
* Group functionality has been disabled.
* It's a large change and Climacs has no test suite. Bugs probably
still remain.
But it should work nicely most of the time. Otherwise, you'll get a
full refund.
--- /project/climacs/cvsroot/climacs/cl-syntax.lisp 2006/09/02 21:43:56 1.20
+++ /project/climacs/cvsroot/climacs/cl-syntax.lisp 2006/11/12 16:06:06 1.21
@@ -1106,7 +1106,7 @@
(display-parse-tree (target-parse-tree state) syntax pane))))
-(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax cl-syntax) current-p)
+(defmethod redisplay-pane-with-syntax ((pane drei-pane) (syntax cl-syntax) current-p)
(with-slots (top bot) pane
(setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
*current-line* 0
--- /project/climacs/cvsroot/climacs/climacs.asd 2006/09/12 17:24:56 1.56
+++ /project/climacs/cvsroot/climacs/climacs.asd 2006/11/12 16:06:06 1.57
@@ -29,105 +29,31 @@
(defparameter *climacs-directory* (directory-namestring *load-truename*))
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun find-swank-package ()
- (find-package :swank))
- (defun find-swank-system ()
- (handler-case (asdf:find-system :swank)
- (asdf:missing-component ())))
- (defun find-swank ()
- (or (find-swank-package)
- (find-swank-system))))
-
(defsystem :climacs
- :depends-on (:mcclim :flexichain :esa #.(if (find-swank-system) :swank (values)))
+ :depends-on (:mcclim :flexichain)
:components
- ((:module "cl-automaton"
- :components ((:file "automaton-package")
- (:file "eqv-hash" :depends-on ("automaton-package"))
- (:file "state-and-transition" :depends-on ("eqv-hash"))
- (:file "automaton" :depends-on ("state-and-transition" "eqv-hash"))
- (:file "regexp" :depends-on ("automaton"))))
- (:module "Persistent"
- :components ((:file "binseq-package")
- (:file "binseq" :depends-on ("binseq-package"))
- (:file "obinseq" :depends-on ("binseq-package" "binseq"))
- (:file "binseq2" :depends-on ("binseq-package" "obinseq" "binseq"))))
-
- (:file "packages" :depends-on ("cl-automaton" "Persistent"))
- (:file "utils" :depends-on ("packages"))
- (:file "buffer" :depends-on ("packages"))
- (:file "motion" :depends-on ("packages" "buffer" "syntax"))
- (:file "editing" :depends-on ("packages" "buffer" "syntax" "motion" "kill-ring"))
- (:file "persistent-buffer"
- :pathname #p"Persistent/persistent-buffer.lisp"
- :depends-on ("packages" "buffer" "Persistent"))
-
- (:file "base" :depends-on ("packages" "utils" "buffer" "persistent-buffer" "kill-ring"))
- (:file "abbrev" :depends-on ("packages" "buffer" "base"))
- (:file "syntax" :depends-on ("packages" "utils" "buffer" "base"))
- (:file "text-syntax" :depends-on ("packages" "base" "buffer" "syntax" "motion"))
- (:file "delegating-buffer" :depends-on ("packages" "buffer"))
- (:file "kill-ring" :depends-on ("packages"))
- (:file "undo" :depends-on ("packages"))
- (:file "persistent-undo"
- :pathname #p"Persistent/persistent-undo.lisp"
- :depends-on ("packages" "buffer" "persistent-buffer" "undo"))
- (:file "pane" :depends-on ("packages" "utils" "syntax" "buffer" "base"
- "persistent-undo" "persistent-buffer" "abbrev"
- "delegating-buffer" "undo"))
- (:file "fundamental-syntax" :depends-on ("packages" "syntax" "buffer" "pane"
- "base"))
- (:file "cl-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane"))
- (:file "html-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane"))
- (:file "prolog-syntax" :depends-on ("packages" "base" "syntax" "pane" "buffer"))
+ ((:file "packages")
+ (:file "text-syntax" :depends-on ("packages"))
+ (:file "cl-syntax" :depends-on ("packages"))
+ (:file "html-syntax" :depends-on ("packages"))
+ (:file "prolog-syntax" :depends-on ("packages"))
(:file "prolog2paiprolog" :depends-on ("prolog-syntax"))
- (:file "ttcn3-syntax" :depends-on ("packages" "buffer" "syntax" "base"
- "pane"))
- (:file "lisp-syntax" :depends-on ("packages" "utils" "syntax" "buffer" "base" "pane"
- "window-commands" "gui" "groups"))
- (:file "lisp-syntax-swine" :depends-on ("lisp-syntax"))
- (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "motion-commands"
- "editing-commands" "misc-commands"))
- #.(if (find-swank)
- '(:file "lisp-syntax-swank" :depends-on ("lisp-syntax"))
- (values))
- (:file "gui" :depends-on ("packages" "utils" "syntax" "base" "buffer" "undo" "pane"
- "kill-ring" "text-syntax"
- "abbrev" "editing" "motion"))
- (:file "io" :depends-on ("packages" "gui"))
+ (:file "ttcn3-syntax" :depends-on ("packages"))
+ (:file "climacs-lisp-syntax" :depends-on ("core" #+nil groups))
+ (:file "climacs-lisp-syntax-commands" :depends-on ("climacs-lisp-syntax" "misc-commands"))
+ (:file "gui" :depends-on ("packages" "text-syntax"))
(:file "core" :depends-on ("gui"))
- (:file "rectangle" :depends-on ("core"))
- (:file "groups" :depends-on ("core"))
+ (:file "io" :depends-on ("packages" "gui"))
+ #+nil (:file "groups" :depends-on ("core"))
(:file "climacs" :depends-on ("gui" "core"))
-;; (:file "buffer-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 "developer-commands" :depends-on ("core"))
+
(:file "file-commands" :depends-on ("gui" "core"))
- (:file "misc-commands" :depends-on ("gui" "core" "rectangle" "groups"))
- (:file "search-commands" :depends-on ("gui" "core"))
+ (:file "misc-commands" :depends-on ("gui" "core" #+nil "groups"))
+ (:file "search-commands" :depends-on ("gui" "core" #+nil "groups"))
(: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"))))
-
-(defsystem :climacs.tests
- :depends-on (:climacs)
- :components
- ((:file "rt" :pathname #p"testing/rt.lisp")
- (:file "buffer-test" :depends-on ("rt"))
- (:file "base-test" :depends-on ("rt" "buffer-test"))
- (:file "kill-ring-test" :depends-on ("buffer-test"))
- (:module
- "cl-automaton"
- :depends-on ("rt")
- :components
- ((:file "automaton-test-package")
- (:file "eqv-hash-test" :depends-on ("automaton-test-package"))
- (:file "state-and-transition-test" :depends-on ("automaton-test-package"))
- (:file "automaton-test" :depends-on ("automaton-test-package"))
- (:file "regexp-test" :depends-on ("automaton-test-package"))))))
+ (:file "slidemacs" :depends-on ("packages" ))
+ (:file "slidemacs-gui" :depends-on ("packages" "gui" "slidemacs"))))
#+asdf
(defmethod asdf:perform :around ((o asdf:compile-op)
--- /project/climacs/cvsroot/climacs/climacs.lisp 2006/07/11 14:20:20 1.3
+++ /project/climacs/cvsroot/climacs/climacs.lisp 2006/11/12 16:06:06 1.4
@@ -46,8 +46,8 @@
;; SBCL doesn't inherit dynamic bindings when starting new
;; processes, so start a new processes and THEN setup the colors.
(flet ((run ()
- (let ((*bg-color* +black+)
- (*fg-color* +gray+)
+ (let ((*background-color* +black+)
+ (*foreground-color* +gray+)
(*info-bg-color* +darkslategray+)
(*info-fg-color* +gray+)
(*mini-bg-color* +black+)
--- /project/climacs/cvsroot/climacs/core.lisp 2006/09/12 19:49:18 1.10
+++ /project/climacs/cvsroot/climacs/core.lisp 2006/11/12 16:06:06 1.11
@@ -15,323 +15,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
-;;; Misc stuff
-
-(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)
- #'object-equal
- #'object=))
-
-(defun possibly-fill-line ()
- (let* ((pane (current-window))
- (buffer (buffer pane)))
- (when (auto-fill-mode pane)
- (let* ((fill-column (auto-fill-column pane))
- (point (point pane))
- (offset (offset point))
- (tab-width (tab-space-count (stream-default-view pane)))
- (syntax (syntax buffer)))
- (when (>= (buffer-display-column buffer offset tab-width)
- (1- fill-column))
- (fill-line point
- (lambda (mark)
- (syntax-line-indentation mark tab-width syntax))
- fill-column
- tab-width
- (syntax buffer)))))))
-
-(defun insert-character (char)
- (let* ((window (current-window))
- (point (point window)))
- (unless (constituentp char)
- (possibly-expand-abbrev point))
- (when (whitespacep (syntax (buffer window)) char)
- (possibly-fill-line))
- (if (and (slot-value window 'overwrite-mode) (not (end-of-line-p point)))
- (progn
- (delete-range point)
- (insert-object point char))
- (insert-object point char))))
-
-(defun back-to-indentation (mark syntax)
- (beginning-of-line mark)
- (loop until (end-of-line-p mark)
- while (whitespacep syntax (object-after mark))
- do (forward-object mark)))
-
-(defun delete-horizontal-space (mark syntax &optional (backward-only-p nil))
- (let ((mark2 (clone-mark mark)))
- (loop until (beginning-of-line-p mark)
- while (whitespacep syntax (object-before mark))
- do (backward-object mark))
- (unless backward-only-p
- (loop until (end-of-line-p mark2)
- while (whitespacep syntax (object-after mark2))
- do (forward-object mark2)))
- (delete-region mark mark2)))
-
-(defun goto-position (mark pos)
- (setf (offset mark) pos))
-
-(defun goto-line (mark line-number)
- (loop with m = (clone-mark (low-mark (buffer mark))
- :right)
- initially (beginning-of-buffer m)
- do (end-of-line m)
- until (end-of-buffer-p m)
- repeat (1- line-number)
- do (incf (offset m))
- (end-of-line m)
- finally (beginning-of-line m)
- (setf (offset mark) (offset m))))
-
-(defun indent-current-line (pane point)
- (let* ((buffer (buffer pane))
- (view (stream-default-view pane))
- (tab-space-count (tab-space-count view))
- (indentation (syntax-line-indentation point
- tab-space-count
- (syntax buffer))))
- (indent-line point indentation (and (indent-tabs-mode buffer)
- tab-space-count))))
-
-(defun insert-pair (mark syntax &optional (count 0) (open #\() (close #\)))
- (cond ((> count 0)
- (loop while (and (not (end-of-buffer-p mark))
- (whitespacep syntax (object-after mark)))
- do (forward-object mark)))
- ((< count 0)
- (setf count (- count))
- (loop repeat count do (backward-expression mark syntax))))
- (unless (or (beginning-of-buffer-p mark)
- (whitespacep syntax (object-before mark)))
- (insert-object mark #\Space))
- (insert-object mark open)
- (let ((here (clone-mark mark)))
- (loop repeat count
- do (forward-expression here syntax))
- (insert-object here close)
- (unless (or (end-of-buffer-p here)
- (whitespacep syntax (object-after here)))
- (insert-object here #\Space))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Character case
-
-(defun downcase-word (mark syntax &optional (n 1))
- "Convert the next N words to lowercase, leaving mark after the last word."
- (loop repeat n
- do (forward-to-word-boundary mark syntax)
- (let ((offset (offset mark)))
- (forward-word mark syntax 1 nil)
- (downcase-region offset mark))))
-
-(defun upcase-word (mark syntax &optional (n 1))
- "Convert the next N words to uppercase, leaving mark after the last word."
- (loop repeat n
- do (forward-to-word-boundary mark syntax)
- (let ((offset (offset mark)))
- (forward-word mark syntax 1 nil)
- (upcase-region offset mark))))
-
-(defun capitalize-word (mark syntax &optional (n 1))
- "Capitalize the next N words, leaving mark after the last word."
- (loop repeat n
- do (forward-to-word-boundary mark syntax)
- (let ((offset (offset mark)))
- (forward-word mark syntax 1 nil)
- (capitalize-region offset mark))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Indentation
-
-(defun indent-region (pane mark1 mark2)
- "Indent all lines in the region delimited by `mark1' and `mark2'
- according to the rules of the active syntax in `pane'."
- (let* ((buffer (buffer pane))
- (view (clim:stream-default-view pane))
- (tab-space-count (tab-space-count view))
- (tab-width (and (indent-tabs-mode buffer)
- tab-space-count))
- (syntax (syntax buffer)))
- (do-buffer-region-lines (line mark1 mark2)
- (let ((indentation (syntax-line-indentation
- line
- tab-space-count
- syntax)))
- (indent-line line indentation tab-width))
- ;; We need to update the syntax every time we perform an
- ;; indentation, so that subsequent indentations will be
- ;; correctly indented (this matters in list forms). FIXME: This
- ;; should probably happen automatically.
- (update-syntax buffer syntax))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Auto fill
-
-(defun fill-line (mark syntax-line-indentation-function fill-column tab-width syntax
- &optional (compress-whitespaces t))
- "Breaks the contents of line pointed to by MARK up to MARK into
-multiple lines such that none of them is longer than FILL-COLUMN. If
-COMPRESS-WHITESPACES is non-nil, whitespaces are compressed after the
-decision is made to break the line at a point. For now, the
-compression means just the deletion of trailing whitespaces."
- (let ((begin-mark (clone-mark mark)))
- (beginning-of-line begin-mark)
- (loop with column = 0
- with line-beginning-offset = (offset begin-mark)
- with walking-mark = (clone-mark begin-mark)
- while (mark< walking-mark mark)
- as object = (object-after walking-mark)
- do (case object
- (#\Space
- (setf (offset begin-mark) (offset walking-mark))
- (incf column))
- (#\Tab
- (setf (offset begin-mark) (offset walking-mark))
- (incf column (- tab-width (mod column tab-width))))
- (t
- (incf column)))
- (when (and (>= column fill-column)
- (/= (offset begin-mark) line-beginning-offset))
- (when compress-whitespaces
- (let ((offset (buffer-search-backward
- (buffer begin-mark)
- (offset begin-mark)
- #(nil)
- :test #'(lambda (o1 o2)
- (declare (ignore o2))
- (not (whitespacep syntax o1))))))
- (when offset
- (delete-region begin-mark (1+ offset)))))
- (insert-object begin-mark #\Newline)
- (incf (offset begin-mark))
- (let ((indentation
- (funcall syntax-line-indentation-function begin-mark)))
- (indent-line begin-mark indentation tab-width))
- (beginning-of-line begin-mark)
- (setf line-beginning-offset (offset begin-mark))
- (setf (offset walking-mark) (offset begin-mark))
- (setf column 0))
- (incf (offset walking-mark)))))
-
-(defun fill-region (mark1 mark2 syntax-line-indentation-function fill-column tab-width syntax
- &optional (compress-whitespaces t))
- "Fill the region delimited by `mark1' and `mark2'. `Mark1' must be
-mark<= `mark2.'"
- (let* ((buffer (buffer mark1)))
- (do-buffer-region (object offset buffer
- (offset mark1) (offset mark2))
- (when (eql object #\Newline)
- (setf object #\Space)))
- (when (>= (buffer-display-column buffer (offset mark2) tab-width)
- (1- fill-column))
- (fill-line mark2
- syntax-line-indentation-function
- fill-column
- tab-width
- compress-whitespaces
- syntax))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Indentation
-
-(defgeneric indent-line (mark indentation tab-width)
- (:documentation "Indent the line containing mark with indentation
-spaces. Use tabs and spaces if tab-width is not nil, otherwise use
-spaces only."))
-
-(defun indent-line* (mark indentation tab-width left)
- (let ((mark2 (clone-mark mark)))
- (beginning-of-line mark2)
- (loop until (end-of-buffer-p mark2)
- as object = (object-after mark2)
- while (or (eql object #\Space) (eql object #\Tab))
- do (delete-range mark2 1))
- (loop until (zerop indentation)
- do (cond ((and tab-width (>= indentation tab-width))
- (insert-object mark2 #\Tab)
- (when left ; spaces must follow tabs
- (forward-object mark2))
- (decf indentation tab-width))
- (t
- (insert-object mark2 #\Space)
- (decf indentation))))))
-
-(defmethod indent-line ((mark left-sticky-mark) indentation tab-width)
- (indent-line* mark indentation tab-width t))
-
-(defmethod indent-line ((mark right-sticky-mark) indentation tab-width)
- (indent-line* mark indentation tab-width nil))
-
-(defun delete-indentation (mark)
- (beginning-of-line mark)
- (unless (beginning-of-buffer-p mark)
- (delete-range mark -1)
- (loop until (end-of-buffer-p mark)
- while (buffer-whitespacep (object-after mark))
- do (delete-range mark 1))
- (loop until (beginning-of-buffer-p mark)
- while (buffer-whitespacep (object-before mark))
- do (delete-range mark -1))
- (when (and (not (beginning-of-buffer-p mark))
- (constituentp (object-before mark)))
- (insert-object mark #\Space))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Syntax handling
-
-(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)))
- (t
- (beep)
- (display-message "No such syntax: ~A." syntax)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
;;; Buffer handling
(defmethod frame-make-new-buffer ((application-frame climacs)
@@ -347,7 +30,7 @@
:key #'name :test #'string=)))
(when b (erase-buffer b))))
-(defmethod erase-buffer ((buffer climacs-buffer))
+(defmethod erase-buffer ((buffer drei-buffer))
(let* ((point (point buffer))
(mark (clone-mark point)))
(beginning-of-buffer mark)
@@ -384,7 +67,7 @@
(defgeneric switch-to-buffer (pane buffer))
-(defmethod switch-to-buffer ((pane extended-pane) (buffer climacs-buffer))
+(defmethod switch-to-buffer ((pane drei) (buffer drei-buffer))
(with-accessors ((buffers buffers)) *application-frame*
(let* ((position (position buffer buffers))
(pane (current-window)))
@@ -396,9 +79,9 @@
(full-redisplay pane)
buffer)))
-(defmethod switch-to-buffer ((pane typeout-pane) (buffer climacs-buffer))
+(defmethod switch-to-buffer ((pane typeout-pane) (buffer drei-buffer))
(let ((usable-pane (or (find-if #'(lambda (pane)
- (typep pane 'extended-pane))
+ (typep pane 'drei))
(windows *application-frame*))
(split-window t))))
(switch-to-buffer usable-pane buffer)))
@@ -412,14 +95,14 @@
;; ;;; FIXME: see the comment by (SETF SYNTAX) :AROUND. -- CSR,
;; ;;; 2005-10-31.
-;; (defmethod (setf buffer) :around (buffer (pane extended-pane))
+;; (defmethod (setf buffer) :around (buffer (pane drei))
;; (call-next-method)
;; (note-pane-syntax-changed pane (syntax buffer)))
(defgeneric kill-buffer (buffer))
-(defmethod kill-buffer ((buffer climacs-buffer))
- (with-slots (buffers) *application-frame*
+(defmethod kill-buffer ((buffer drei-buffer))
+ (with-accessors ((buffers buffers)) *application-frame*
(when (and (needs-saving buffer)
(handler-case (accept 'boolean :prompt "Save buffer first?")
(error () (progn (beep)
@@ -453,13 +136,13 @@
"." (pathname-type pathname))))
(defun syntax-class-name-for-filepath (filepath)
- (or (climacs-syntax::syntax-description-class-name
+ (or (drei-syntax::syntax-description-class-name
(find (or (pathname-type filepath)
(pathname-name filepath))
- climacs-syntax::*syntaxes*
+ drei-syntax::*syntaxes*
:test (lambda (x y)
(member x y :test #'string-equal))
- :key #'climacs-syntax::syntax-description-pathname-types))
+ :key #'drei-syntax::syntax-description-pathname-types))
*default-syntax*))
(defun evaluate-attributes (buffer options)
@@ -634,7 +317,7 @@
(t
(let ((existing-buffer (find-buffer-with-pathname filepath)))
(if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t))
- (switch-to-buffer existing-buffer)
+ (switch-to-buffer *current-window* existing-buffer)
(progn
(when readonlyp
(unless (probe-file filepath)
--- /project/climacs/cvsroot/climacs/developer-commands.lisp 2006/07/24 13:24:40 1.3
+++ /project/climacs/cvsroot/climacs/developer-commands.lisp 2006/11/12 16:06:06 1.4
@@ -43,7 +43,7 @@
(define-gesture-name :select-other #+mcclim :pointer-button-press #-mcclim :pointer-button (:left :meta) :unique nil)
(define-presentation-translator lisp-string-to-string
- (climacs-lisp-syntax::lisp-string string development-table
+ (drei-lisp-syntax::lisp-string string development-table
:gesture :select-other
:tester-definitive t
:menu nil
--- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/09/12 19:49:18 1.25
+++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/11/12 16:06:06 1.26
@@ -99,10 +99,10 @@
name))))))))
(define-presentation-method present (object (type pathname)
- stream (view climacs-textual-view) &key)
+ stream (view drei-textual-view) &key)
(princ (namestring object) stream))
-(define-presentation-method accept ((type pathname) stream (view climacs-textual-view)
+(define-presentation-method accept ((type pathname) stream (view drei-textual-view)
&key (default nil defaultp) (default-type type))
(multiple-value-bind (pathname success string)
(complete-input stream
--- /project/climacs/cvsroot/climacs/groups.lisp 2006/09/11 20:13:32 1.3
+++ /project/climacs/cvsroot/climacs/groups.lisp 2006/11/12 16:06:06 1.4
@@ -113,7 +113,7 @@
NIL. If a pathname is returned, it is assumed to be safe to find
the file with that name."
(typecase element
- (climacs-buffer
+ (drei-buffer
(find element (buffers *application-frame*)))
((or pathname string)
(or (find-buffer-with-pathname (pathname element))
@@ -125,7 +125,7 @@
(defun display-group-element (element stream)
(let ((norm-element (normalise-group-element element)))
(typecase norm-element
- (climacs-buffer
+ (drei-buffer
(present norm-element 'buffer stream))
((or pathname string)
(present norm-element 'pathname stream)))))
@@ -133,7 +133,7 @@
;; Singular group elements.
(defmethod group-buffers ((group group-element))
(let ((element (element group)))
- (cond ((and (typep element 'climacs-buffer)
+ (cond ((and (typep element 'drei-buffer)
(find element (buffers *application-frame*)))
(list element))
((or (pathnamep element)
@@ -144,7 +144,7 @@
(defmethod ensure-group-buffers ((group group-element))
(typecase (element group)
- (climacs-buffer
+ (drei-buffer
(unless (find (element group) (buffers *application-frame*))
(ensure-open-file (pathname (filepath (element group))))))
(pathname
--- /project/climacs/cvsroot/climacs/gui.lisp 2006/09/12 19:49:18 1.231
+++ /project/climacs/cvsroot/climacs/gui.lisp 2006/11/12 16:06:06 1.232
@@ -28,17 +28,52 @@
(in-package :climacs-gui)
-(defclass extended-pane (climacs-pane esa-pane-mixin)
- (;; for next-line and previous-line commands
- (goal-column :initform nil :accessor goal-column)
- ;; for dynamic abbrev expansion
- (original-prefix :initform nil :accessor original-prefix)
- (prefix-start-offset :initform nil :accessor prefix-start-offset)
- (dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark)
- (overwrite-mode :initform nil :accessor overwrite-mode)))
+(defvar *default-external-format* :utf-8
+ "The encoding to use by default when reading and saving
+files.")
+
+(defvar *with-scrollbars* t
+ "If T, classic look and feel. If NIL, stripped-down look (:")
+
+(defvar *show-info-pane-mark-position* nil
+ "If T, show the line number and column number in the info pane
+ of all panes. If NIL, don't. This is off by default, as finding
+ the line and column numbers is potentially expensive.")
+
+(defclass climacs-buffer (drei-buffer)
+ ((%external-format :initform *default-external-format*
+ :accessor external-format
+ :documentation "The external format that was
+used when reading the source destination of the buffer
+contents.")))
+
+(defclass climacs-pane (drei-pane esa-pane-mixin)
+ ()
+ (:default-initargs
+ :buffer (make-instance 'climacs-buffer)
+ :command-table 'global-climacs-table
+ :width 900 :height 400))
+
+;; Ensure that only one pane can be active.
+(defmethod (setf active) :after ((new-val (eql t)) (climacs-pane climacs-pane))
+ (mapcar #'(lambda (pane)
+ (unless (eq climacs-pane pane)
+ (setf (active pane) nil)))
+ (windows (pane-frame climacs-pane))))
+
+(defmethod command-table ((drei climacs-pane))
+ (command-table (pane-frame drei)))
(defclass typeout-pane (application-pane esa-pane-mixin)
- ())
+ ((%active :accessor active
+ :initform nil
+ :initarg :active)))
+
+(defmethod buffer ((pane typeout-pane)))
+
+(defmethod point ((pane typeout-pane)))
+
+(defmethod mark ((pane typeout-pane)))
(defmethod full-redisplay ((pane typeout-pane)))
@@ -49,29 +84,35 @@
(declare (ignore pane))
nil)
-(defmethod buffer-pane-p ((pane extended-pane))
+(defmethod buffer-pane-p ((pane climacs-pane))
t)
+(defmethod in-focus-p ((pane climacs-pane))
+ (eq pane (first (windows *application-frame*))))
+
+(defvar *info-bg-color* +gray85+)
+(defvar *info-fg-color* +black+)
+(defvar *mini-bg-color* +white+)
+(defvar *mini-fg-color* +black+)
+
(defclass climacs-info-pane (info-pane)
()
(:default-initargs
:height 20 :max-height 20 :min-height 20
:display-function 'display-info
- :incremental-redisplay t))
+ :incremental-redisplay t
+ :background *info-bg-color*
+ :foreground *info-fg-color*
+ :width 900))
(defclass climacs-minibuffer-pane (minibuffer-pane)
()
(:default-initargs
- :height 20 :max-height 20 :min-height 20
- :default-view +climacs-textual-view+))
-
-(defparameter *with-scrollbars* t
- "If T, classic look and feel. If NIL, stripped-down look (:")
-
-(defparameter *show-info-pane-mark-position* nil
- "If T, show the line number and column number in the info pane
- of all panes. If NIL, don't. This is off by default, as finding
- the line and column numbers is potentially expensive.")
+ :height 20 :max-height 20 :min-height 20
+ :default-view +drei-textual-view+
+ :background *mini-bg-color*
+ :foreground *mini-fg-color*
+ :width 900))
;;; Basic command tables follow. The global command table,
;;; `global-climacs-table', inherits from these, so they should not
@@ -83,35 +124,13 @@
;;; Basic functionality
(make-command-table 'base-table :errorp nil)
-;;; buffers
+;;; Buffers
(make-command-table 'buffer-table :errorp nil)
-;;; case
-(make-command-table 'case-table :errorp nil)
-;;; comments
-(make-command-table 'comment-table :errorp nil)
-;;; deleting
-(make-command-table 'deletion-table :errorp nil)
-;;; commands used for climacs development
+;;; Commands used for climacs development
(make-command-table 'development-table :errorp nil)
-;;; editing - making changes to a buffer
-(make-command-table 'editing-table :errorp nil)
-;;; filling
-(make-command-table 'fill-table :errorp nil)
-;;; indentation
-(make-command-table 'indent-table :errorp nil)
-;;; information about the buffer
-(make-command-table 'info-table :errorp nil)
-;;; marking things
-(make-command-table 'marking-table :errorp nil)
-;;; moving around
-(make-command-table 'movement-table :errorp nil)
-;;; panes
+;;; Panes
(make-command-table 'pane-table :errorp nil)
-;;; searching
-(make-command-table 'search-table :errorp nil)
-;;; self-insertion
-(make-command-table 'self-insert-table :errorp nil)
-;;; windows
+;;; Windows
(make-command-table 'window-table :errorp nil)
;;; customization of help. FIXME: this might be better done by having
@@ -121,9 +140,9 @@
(make-command-table 'climacs-help-table :inherit-from '(help-table)
:errorp nil)
-;; We have a special command table for typeout panes because we want
-;; to keep being able to do window, buffer, etc, management, but we do
-;; not want any actual editing commands.
+;;; We have a special command table for typeout panes because we want
+;;; to keep being able to do window, buffer, etc, management, but we do
+;;; not want any actual editing commands.
(make-command-table 'typeout-pane-table
:errorp nil
:inherit-from '(global-esa-table
@@ -133,71 +152,52 @@
development-table
climacs-help-table))
-(defvar *bg-color* +white+)
-(defvar *fg-color* +black+)
-(defvar *info-bg-color* +gray85+)
-(defvar *info-fg-color* +black+)
-(defvar *mini-bg-color* +white+)
-(defvar *mini-fg-color* +black+)
+(defclass climacs-command-table (standard-command-table)
+ ())
-(define-application-frame climacs (standard-application-frame
- esa-frame-mixin)
- ((buffers :initform '() :accessor buffers)
- (groups :initform (make-hash-table :test #'equal) :accessor groups)
- (active-group :initform nil :accessor active-group)
- (kill-ring :initform (make-instance 'kill-ring :max-size 7) :accessor kill-ring))
+(defmethod command-table-inherit-from ((table climacs-command-table))
+ (append (when *current-syntax* (list (command-table *current-syntax*)))
+ '(global-climacs-table)
+ (call-next-method)))
+
+(define-application-frame climacs (esa-frame-mixin
+ standard-application-frame)
+ ((%buffers :initform '() :accessor buffers)
+ (%groups :initform (make-hash-table :test #'equal) :accessor groups)
+ (%active-group :initform nil :accessor active-group)
+ (%kill-ring :initform (make-instance 'kill-ring :max-size 7) :accessor kill-ring)
+ (%command-table :initform (make-instance 'climacs-command-table
+ :name 'climacs-dispatching-table)
+ :accessor find-applicable-command-table))
(:command-table (global-climacs-table
- :inherit-from (global-esa-table
- esa-io-table
- keyboard-macro-table
- climacs-help-table
- base-table
- buffer-table
- case-table
- comment-table
- deletion-table
- development-table
- editing-table
- fill-table
- indent-table
- info-table
- marking-table
- movement-table
- pane-table
- search-table
- self-insert-table
- window-table)))
+ :inherit-from (esa-io-table
+ keyboard-macro-table
+ climacs-help-table
+ base-table
+ buffer-table
+ case-table
+ development-table
+ info-table
+ pane-table
+ window-table
+ editor-table
+ global-esa-table)))
(:menu-bar nil)
(:panes
(climacs-window
- (let* ((extended-pane
- (make-pane 'extended-pane
- :width 900 :height 400
- :end-of-line-action :scroll
- :incremental-redisplay t
- :background *bg-color*
- :foreground *fg-color*
- :display-function 'display-window
- :command-table 'global-climacs-table))
- (info-pane
- (make-pane 'climacs-info-pane
- :master-pane extended-pane
- :background *info-bg-color*
- :foreground *info-fg-color*
- :width 900)))
- (setf (windows *application-frame*) (list extended-pane)
- (buffers *application-frame*) (list (buffer extended-pane)))
-
+ (let* ((climacs-pane (make-pane 'climacs-pane
+ :active t))
+ (info-pane (make-pane 'climacs-info-pane
+ :master-pane climacs-pane)))
+ (setf (windows *application-frame*) (list climacs-pane)
+ (buffers *application-frame*) (list (buffer climacs-pane)))
(vertically ()
(if *with-scrollbars*
(scrolling ()
- extended-pane)
- extended-pane)
+ climacs-pane)
+ climacs-pane)
info-pane)))
- (minibuffer (make-pane 'climacs-minibuffer-pane
- :background *mini-bg-color*
- :foreground *mini-fg-color*
- :width 900)))
+ (minibuffer (make-pane 'climacs-minibuffer-pane)))
(:layouts
(default
(vertically (:scroll-bars nil)
@@ -207,23 +207,22 @@
(let ((*kill-ring* (kill-ring frame)))
(esa-top-level frame :prompt "M-x "))))))
+(define-esa-top-level ((frame climacs) command-parser
+ command-unparser
+ partial-command-parser
+ prompt)
+ :bindings ((*current-point* (current-point))
+ (*current-mark* (current-mark))
+ (*previous-command* (previous-command *current-window*))
+ (*current-syntax* (and *current-buffer*
+ (syntax *current-buffer*)))))
+
(defmethod frame-standard-input ((frame climacs))
(get-frame-pane frame 'minibuffer))
-(defun current-window ()
- (car (windows *application-frame*)))
-
-(defun current-point ()
- "Return the current panes point."
- (point (current-window)))
-
-(defun current-mark ()
- "Return the current panes mark."
- (mark (current-window)))
-
(defmethod frame-current-buffer ((application-frame climacs))
"Return the current buffer."
- (buffer (car (windows application-frame))))
+ (buffer (frame-current-window application-frame)))
(defun any-buffer ()
"Return some buffer, any buffer, as long as it is a buffer!"
@@ -296,59 +295,24 @@
"")
pane))))
-(defun display-window (frame pane)
- "The display function used by the climacs application frame."
- (redisplay-pane pane (eq pane (car (windows frame)))))
-
-(defmethod handle-repaint :before ((pane extended-pane) region)
- (declare (ignore region))
- (redisplay-frame-pane *application-frame* pane))
+(defmethod execute-drei-command ((drei-instance climacs-pane) command)
+ (execute-frame-command (pane-frame drei-instance) command))
(defmethod execute-frame-command :around ((frame climacs) command)
- (let ((current-window (car (windows frame))))
- (handler-case
- (progn
- (if (buffer-pane-p current-window)
- (with-undo ((buffers frame))
- (call-next-method))
- (call-next-method))
- (loop for buffer in (buffers frame)
- do (when (modified-p buffer)
- (clear-modify buffer))))
- (offset-before-beginning ()
- (beep) (display-message "Beginning of buffer"))
- (offset-after-end ()
- (beep) (display-message "End of buffer"))
- (motion-before-beginning ()
- (beep) (display-message "Beginning of buffer"))
- (motion-after-end ()
- (beep) (display-message "End of buffer"))
- (no-expression ()
- (beep) (display-message "No expression around point"))
- (no-such-operation ()
- (beep) (display-message "Operation unavailable for syntax"))
- (buffer-read-only ()
- (beep) (display-message "Buffer is read only")))))
+ (handling-drei-conditions
+ (with-undo ((buffers frame))
+ (call-next-method))
+ (loop for buffer in (buffers frame)
+ do (when (modified-p buffer)
+ (clear-modify buffer)))))
(defmethod execute-frame-command :after ((frame climacs) command)
(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))
- (cond ((typep (current-window) 'typeout-pane)
- (find-command-table 'typeout-pane-table))
- ((buffer-pane-p (current-window))
- (or (let ((syntax (syntax (buffer (current-window)))))
- ;; Why all this absurd checking? Smells fishy.
- (and (slot-exists-p syntax 'command-table)
- (slot-boundp syntax 'command-table)
- (slot-value syntax 'command-table)
- (find-command-table (slot-value syntax 'command-table))))
- (find-command-table 'global-climacs-table)))))
+ do (when (syntax buffer)
+ (update-syntax buffer (syntax buffer)))
+ do (when (modified-p buffer)
+ (setf (needs-saving buffer) t)))))
(define-command (com-full-redisplay :name t :command-table base-table) ()
"Redisplay the contents of the current window.
@@ -359,18 +323,6 @@
'base-table
'((#\l :control)))
-(define-command com-self-insert ((count 'integer))
- (loop repeat count do (insert-character *current-gesture*)))
-
-(loop for code from (char-code #\Space) to (char-code #\~)
- do (set-key `(com-self-insert ,*numeric-argument-marker*)
- 'self-insert-table
- (list (list (code-char code)))))
-
-(set-key `(com-self-insert ,*numeric-argument-marker*)
- 'self-insert-table
- '((#\Newline)))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Pane functions
[86 lines skipped]
--- /project/climacs/cvsroot/climacs/html-syntax.lisp 2006/09/02 21:43:56 1.35
+++ /project/climacs/cvsroot/climacs/html-syntax.lisp 2006/11/12 16:06:06 1.36
@@ -697,20 +697,21 @@
(defun handle-whitespace (pane buffer start end)
(let ((space-width (space-width pane))
- (tab-width (tab-width pane)))
- (loop while (< start end)
- do (ecase (buffer-object buffer start)
- (#\Newline (terpri pane)
- (setf (aref *cursor-positions* (incf *current-line*))
- (multiple-value-bind (x y) (stream-cursor-position pane)
- (declare (ignore x))
- y)))
- (#\Space (stream-increment-cursor-position
- pane space-width 0))
- (#\Tab (let ((x (stream-cursor-position pane)))
- (stream-increment-cursor-position
- pane (- tab-width (mod x tab-width)) 0))))
- (incf start))))
+ (tab-width (tab-width pane)))
+ (with-sheet-medium (medium pane)
+ (with-accessors ((cursor-positions cursor-positions)) (syntax buffer)
+ (loop while (< start end)
+ do (case (buffer-object buffer start)
+ (#\Newline (record-line-vertical-offset pane (syntax buffer) (incf *current-line*))
+ (terpri pane)
+ (stream-increment-cursor-position
+ pane (first (aref cursor-positions 0)) 0))
+ ((#\Page #\Return #\Space) (stream-increment-cursor-position
+ pane space-width 0))
+ (#\Tab (let ((x (stream-cursor-position pane)))
+ (stream-increment-cursor-position
+ pane (- tab-width (mod x tab-width)) 0))))
+ (incf start))))))
(defmethod display-parse-tree :around ((entity html-parse-tree) syntax pane)
(with-slots (top bot) pane
@@ -762,42 +763,42 @@
(display-parse-stack (parse-stack-symbol top) top syntax pane)
(display-parse-tree (target-parse-tree state) syntax pane))))
-(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p)
+(defmethod display-drei-contents ((pane clim-stream-pane) (drei drei) (syntax html-syntax))
(with-slots (top bot) pane
- (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
- *current-line* 0
- (aref *cursor-positions* 0) (stream-cursor-position pane))
- (with-slots (lexer) syntax
- (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
- 1.0)))
- ;; find the last token before bot
- (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
- ;; go back to a token before bot
- (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
- do (decf end-token-index))
- ;; go forward to the last token before bot
- (loop until (or (= end-token-index (nb-lexemes lexer))
- (mark> (start-offset (lexeme lexer end-token-index)) bot))
- do (incf end-token-index))
- (let ((start-token-index end-token-index))
- ;; go back to the first token after top, or until the previous token
- ;; contains a valid parser state
- (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
- (not (parse-state-empty-p
- (slot-value (lexeme lexer (1- start-token-index)) 'state))))
- do (decf start-token-index))
- (let ((*white-space-start* (offset top)))
- ;; display the parse tree if any
- (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
- (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
- syntax
- pane))
- ;; display the lexemes
- (with-drawing-options (pane :ink +red+)
- (loop while (< start-token-index end-token-index)
- do (let ((token (lexeme lexer start-token-index)))
- (display-parse-tree token syntax pane))
- (incf start-token-index))))))))
- (when (region-visible-p pane) (display-region pane syntax))
- (display-cursor pane syntax current-p)))
-
+ (with-accessors ((cursor-positions cursor-positions)) syntax
+ (setf cursor-positions (make-array (1+ (number-of-lines-in-region top bot))
+ :initial-element nil)
+ *current-line* 0
+ (aref cursor-positions 0) (multiple-value-list
+ (stream-cursor-position pane))))
+ (setf *white-space-start* (offset top))
+ (with-slots (lexer) syntax
+ (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
+ 1.0)))
+ ;; find the last token before bot
+ (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
+ ;; go back to a token before bot
+ (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
+ do (decf end-token-index))
+ ;; go forward to the last token before bot
+ (loop until (or (= end-token-index (nb-lexemes lexer))
+ (mark> (start-offset (lexeme lexer end-token-index)) bot))
+ do (incf end-token-index))
+ (let ((start-token-index end-token-index))
+ ;; go back to the first token after top, or until the previous token
+ ;; contains a valid parser state
+ (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
+ (not (parse-state-empty-p
+ (slot-value (lexeme lexer (1- start-token-index)) 'state))))
+ do (decf start-token-index))
+ ;; display the parse tree if any
+ (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
+ (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
+ syntax
+ pane))
+ ;; display the lexemes
+ (with-drawing-options (pane :ink +red+)
+ (loop while (< start-token-index end-token-index)
+ do (let ((token (lexeme lexer start-token-index)))
+ (display-parse-tree token syntax pane))
+ (incf start-token-index)))))))))
--- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/09/06 20:07:21 1.25
+++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/11/12 16:06:06 1.26
@@ -1,4 +1,4 @@
-;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
+;;; -*- Mode: Lisp; Package: CLIMACS-COMMANDS -*-
;;; (c) copyright 2004-2005 by
;;; Robert Strandh (strandh(a)labri.fr)
@@ -28,19 +28,6 @@
(in-package :climacs-commands)
-(define-command (com-overwrite-mode :name t :command-table editing-table) ()
- "Toggle overwrite mode for the current mode.
-When overwrite is on, an object entered on the keyboard
-will replace the object after the point.
-When overwrite is off (the default), objects are inserted at point.
-In both cases point is positioned after the new object."
- (with-slots (overwrite-mode) (current-window)
- (setf overwrite-mode (not overwrite-mode))))
-
-(set-key 'com-overwrite-mode
- 'editing-table
- '((:insert)))
-
(define-command (com-not-modified :name t :command-table buffer-table) ()
"Clear the modified flag for the current buffer.
The modified flag is automatically set when the contents
@@ -52,624 +39,6 @@
'buffer-table
'((#\~ :meta :shift)))
-(defun set-fill-column (column)
- (if (> column 1)
- (setf (auto-fill-column (current-window)) column)
- (progn (beep) (display-message "Set Fill Column requires an explicit argument."))))
-
-(define-command (com-set-fill-column :name t :command-table fill-table)
- ((column 'integer :prompt "Column Number:"))
- "Set the fill column to the specified value.
-You must supply a numeric argument. The fill column is
-the column beyond which automatic line-wrapping will occur.
-
-The default fill column is 70."
- (set-fill-column column))
-
-(set-key `(com-set-fill-column ,*numeric-argument-marker*)
- 'fill-table
- '((#\x :control) (#\f)))
-
-(define-command (com-zap-to-object :name t :command-table deletion-table) ()
- "Prompt for an object and kill to the next occurence of that object after point.
-Characters can be entered in #\ format."
- (let* ((item (handler-case (accept 't :prompt "Zap to Object")
- (error () (progn (beep)
- (display-message "Not a valid object")
- (return-from com-zap-to-object nil)))))
- (current-point (point (current-window)))
- (item-mark (clone-mark current-point))
- (current-offset (offset current-point)))
- (search-forward item-mark (vector item))
- (delete-range current-point (- (offset item-mark) current-offset))))
-
-(define-command (com-zap-to-character :name t :command-table deletion-table) ()
- "Prompt for a character and kill to the next occurence of that character after point.
-FIXME: Accepts a string (that is, zero or more characters)
-terminated by a #\NEWLINE. If a zero length string signals an error.
-If a string of length >1, uses the first character of the string."
- (let* ((item-string (handler-case (accept 'string :prompt "Zap to Character") ; Figure out how to get #\d and d. (or 'string 'character)?
- (error () (progn (beep)
- (display-message "Not a valid string. ")
- (return-from com-zap-to-character nil)))))
- (item (subseq item-string 0 1))
- (current-point (point (current-window)))
- (item-mark (clone-mark current-point))
-
- (current-offset (offset current-point)))
- (if (> (length item-string) 1)
- (display-message "Using just the first character"))
- (search-forward item-mark item)
- (delete-range current-point (- (offset item-mark) current-offset))))
-
-(set-key 'com-zap-to-character
- 'deletion-table
- '((#\z :meta)))
-
-(define-command (com-open-line :name t :command-table editing-table)
- ((numarg 'integer :prompt "How many lines?"))
- "Insert a #\Newline and leave point before it.
-With a numeric argument greater than 1, insert that many #\Newlines."
- (open-line (point (current-window)) numarg))
-
-(set-key `(com-open-line ,*numeric-argument-marker*)
- 'editing-table
- '((#\o :control)))
-
-(defmacro define-mark-unit-command (unit command-table &key
- move-point
- noun
- plural)
- "Define a COM-MARK-<UNIT> for `unit' command and put it in
- `command-table'."
- (labels ((symbol (&rest strings)
- (intern (apply #'concat strings)))
- (concat (&rest strings)
- (apply #'concatenate 'STRING (mapcar #'string strings))))
- (let ((forward (symbol "FORWARD-" unit))
- (backward (symbol "BACKWARD-" unit))
- (noun (or noun (string-downcase unit)))
- (plural (or plural (concat (string-downcase unit) "s"))))
- `(define-command (,(symbol "COM-MARK-" unit)
- :name t
- :command-table ,command-table)
- ((count 'integer :prompt ,(concat "Number of " plural)))
- ,(if (not (null move-point))
- (concat "Place point and mark around the current " noun ".
-Put point at the beginning of the current " noun ", and mark at the end.
-With a positive numeric argument, put mark that many " plural " forward.
-With a negative numeric argument, put point at the end of the current
-" noun " and mark that many " plural " backward.
-Successive invocations extend the selection.")
- (concat "Place mark at the next " noun " end.
-With a positive numeric argument, place mark at the end of
-that many " plural " forward. With a negative numeric argument,
-place mark at the beginning of that many " plural " backward.
-
-Successive invocations extend the selection."))
- (let* ((pane (current-window))
- (point (point pane))
- (mark (mark pane)))
- (unless (eq (previous-command pane) 'com-mark-word)
- (setf (offset mark) (offset point))
- ,(when (not (null move-point))
- `(if (plusp count)
- (,backward point (syntax (buffer pane)))
- (,forward point (syntax (buffer pane))))))
- (,forward mark (syntax (buffer pane)) count))))))
-
-(define-mark-unit-command word marking-table)
-(define-mark-unit-command expression marking-table)
-(define-mark-unit-command paragraph marking-table :move-point t)
-(define-mark-unit-command definition marking-table :move-point t)
-
-(set-key `(com-mark-word ,*numeric-argument-marker*)
- 'marking-table
- '((#\@ :meta :shift)))
-
-(set-key `(com-mark-paragraph ,*numeric-argument-marker*)
- 'marking-table
- '((#\h :meta)))
-
-(set-key 'com-mark-definition
- 'marking-table
- '((#\h :control :meta)))
-
-(define-command (com-upcase-region :name t :command-table case-table) ()
- "Convert the region to upper case."
- (let ((cw (current-window)))
- (upcase-region (mark cw) (point cw))))
-
-(define-command (com-downcase-region :name t :command-table case-table) ()
- "Convert the region to lower case."
- (let ((cw (current-window)))
- (downcase-region (mark cw) (point cw))))
-
-(define-command (com-capitalize-region :name t :command-table case-table) ()
- "Capitalize each word in the region."
- (let ((cw (current-window)))
- (capitalize-region (mark cw) (point cw))))
-
-(define-command (com-upcase-word :name t :command-table case-table) ()
- "Convert the characters from point until the next word end to upper case.
-Leave point at the word end."
- (upcase-word (point (current-window))
- (syntax (buffer (current-window)))))
-
-(set-key 'com-upcase-word
- 'case-table
- '((#\u :meta)))
-
-(define-command (com-downcase-word :name t :command-table case-table) ()
- "Convert the characters from point until the next word end to lower case.
-Leave point at the word end."
- (downcase-word (point (current-window))
- (syntax (buffer (current-window)))))
-
-(set-key 'com-downcase-word
- 'case-table
- '((#\l :meta)))
-
-(define-command (com-capitalize-word :name t :command-table case-table) ()
- "Capitalize the next word.
-If point is in a word, convert the next character to
-upper case and the remaining letters in the word to lower case.
-If point is before the start of a word, convert the first character
-of that word to upper case and the rest of the letters to lower case.
-
-Leave point at the word end."
- (capitalize-word (point (current-window))
- (syntax (buffer (current-window)))))
-
-(set-key 'com-capitalize-word
- 'case-table
- '((#\c :meta)))
-
-(define-command (com-tabify-region :name t :command-table editing-table) ()
- "Replace runs of spaces with tabs in region where possible.
-Uses TAB-SPACE-COUNT of the STREAM-DEFAULT-VIEW of the pane."
- (let ((pane (current-window)))
- (tabify-region
- (mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
-
-(define-command (com-untabify-region :name t :command-table editing-table) ()
- "Replace tabs with equivalent runs of spaces in the region.
-Uses TAB-SPACE-COUNT of the STREAM-DEFAULT-VIEW of the pane."
- (let ((pane (current-window)))
- (untabify-region
- (mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
-
-(define-command (com-indent-line :name t :command-table indent-table) ()
- (let* ((pane (current-window))
- (point (point pane)))
- (indent-current-line pane point)))
-
-(set-key 'com-indent-line
- 'indent-table
- '((#\Tab)))
-
-(set-key 'com-indent-line
- 'indent-table
- '((#\i :control)))
-
-(define-command (com-newline-and-indent :name t :command-table indent-table) ()
- "Inserts a newline and indents the new line."
- (let* ((pane (current-window))
- (point (point pane)))
- (insert-object point #\Newline)
- (update-syntax (current-buffer *application-frame*)
- (syntax (current-buffer *application-frame*)))
- (indent-current-line pane point)))
-
-(set-key 'com-newline-and-indent
- 'indent-table
- '((#\j :control)))
-
-(define-command (com-indent-region :name t :command-table indent-table) ()
- "Indent every line of the current region as specified by the
-syntax for the buffer."
- (let* ((pane (current-window))
- (point (point pane))
- (mark (mark pane)))
- (indent-region pane point mark)))
-
-(define-command (com-delete-indentation :name t :command-table indent-table) ()
- "Join current line to previous non-blank line.
-Leaves a single space between the last non-whitespace object
-of the previous line and the first non-whitespace object of
-the current line, and point after that space. If there is no
-previous non-blank line, deletes all whitespace at the
-beginning of the buffer at leaves point there."
- (delete-indentation (point (current-window))))
-
-(set-key 'com-delete-indentation
- 'indent-table
- '((#\^ :shift :meta)))
-
-(define-command (com-auto-fill-mode :name t :command-table fill-table) ()
- (let ((pane (current-window)))
- (setf (auto-fill-mode pane) (not (auto-fill-mode pane)))))
-
-(define-command (com-fill-paragraph :name t :command-table fill-table) ()
- (let* ((pane (current-window))
- (buffer (buffer pane))
- (syntax (syntax buffer))
- (point (point pane))
- (begin-mark (clone-mark point))
- (end-mark (clone-mark point)))
- (unless (eql (object-before begin-mark) #\Newline)
- (backward-paragraph begin-mark syntax))
- (unless (eql (object-after end-mark) #\Newline)
- (forward-paragraph end-mark syntax))
- (do-buffer-region (object offset buffer
- (offset begin-mark) (offset end-mark))
- (when (eql object #\Newline)
- (setf object #\Space)))
- (let ((point-backup (clone-mark point)))
- (setf (offset point) (offset end-mark))
- (possibly-fill-line)
- (setf (offset point) (offset point-backup)))))
-
-(set-key 'com-fill-paragraph
- 'fill-table
- '((#\q :meta)))
-
-(define-command (com-beginning-of-buffer :name t :command-table movement-table) ()
- "Move point to the beginning of the buffer."
- (beginning-of-buffer (point (current-window))))
-
-(set-key 'com-beginning-of-buffer
- 'movement-table
- '((#\< :shift :meta)))
-
-(set-key 'com-beginning-of-buffer
- 'movement-table
- '((:home :control)))
-
-(define-command (com-page-down :name t :command-table movement-table) ()
- (let ((pane (current-window)))
- (page-down pane)))
-
-(set-key 'com-page-down
- 'movement-table
- '((#\v :control)))
-
-(set-key 'com-page-down
- 'movement-table
- '((:next)))
-
-(define-command (com-page-up :name t :command-table movement-table) ()
- (let ((pane (current-window)))
- (page-up pane)))
-
-(set-key 'com-page-up
- 'movement-table
- '((#\v :meta)))
-
-(set-key 'com-page-up
- 'movement-table
- '((:prior)))
-
-(define-command (com-end-of-buffer :name t :command-table movement-table) ()
- "Move point to the end of the buffer."
- (end-of-buffer (point (current-window))))
-
-(set-key 'com-end-of-buffer
- 'movement-table
- '((#\> :shift :meta)))
-
-(set-key 'com-end-of-buffer
- 'movement-table
- '((:end :control)))
-
-(define-command (com-mark-whole-buffer :name t :command-table marking-table) ()
- "Place point at the beginning and mark at the end of the buffer."
- (beginning-of-buffer (point (current-window)))
- (end-of-buffer (mark (current-window))))
-
-(set-key 'com-mark-whole-buffer
- 'marking-table
- '((#\x :control) (#\h)))
-
-(define-command (com-back-to-indentation :name t :command-table movement-table) ()
- "Move point to the first non-whitespace object on the current line.
-If there is no non-whitespace object, leaves point at the end of the line."
- (back-to-indentation (point (current-window))
- (syntax (buffer (current-window)))))
-
-(set-key 'com-back-to-indentation
- 'movement-table
- '((#\m :meta)))
-
-(define-command (com-delete-horizontal-space :name t :command-table deletion-table)
- ((backward-only-p
- 'boolean :prompt "Delete backwards only?"))
- "Delete whitespace around point.
-With a numeric argument, only delete whitespace before point."
- (delete-horizontal-space (point (current-window))
- (syntax (buffer (current-window)))
- backward-only-p))
-
-(set-key `(com-delete-horizontal-space ,*numeric-argument-p*)
- 'deletion-table
- '((#\\ :meta)))
-
-(define-command (com-just-one-space :name t :command-table deletion-table)
- ((count 'integer :prompt "Number of spaces"))
- "Delete whitespace around point, leaving a single space.
-With a positive numeric argument, leave that many spaces.
-
-FIXME: should distinguish between types of whitespace."
- (just-n-spaces (point (current-window))
- count))
-
-(set-key `(com-just-one-space ,*numeric-argument-marker*)
- 'deletion-table
- '((#\Space :meta)))
-
-(define-command (com-goto-position :name t :command-table movement-table)
- ((position 'integer :prompt "Goto Position"))
- "Prompts for an integer, and sets the offset of point to that integer."
- (goto-position
- (point (current-window))
- position))
-
-(define-command (com-goto-line :name t :command-table movement-table)
- ((line-number 'integer :prompt "Goto Line"))
- "Prompts for a line number, and sets point to the beginning of that line.
-The first line of the buffer is 1. Giving a number <1 leaves
-point at the beginning of the buffer. Giving a line number
-larger than the number of the last line in the buffer leaves
[461 lines skipped]
--- /project/climacs/cvsroot/climacs/packages.lisp 2006/09/15 22:34:24 1.120
+++ /project/climacs/cvsroot/climacs/packages.lisp 2006/11/12 16:06:06 1.121
@@ -26,325 +26,22 @@
(in-package :cl-user)
-(defpackage :climacs-utils
- (:use :clim-lisp)
- (:export #:with-gensyms
- #:once-only
- #:unlisted
- #:fully-unlisted
- #:listed
- #:list-aref))
-
-(defpackage :climacs-buffer
- (:use :clim-lisp :flexichain :binseq)
- (:export #:buffer #:standard-buffer
- #:mark #:left-sticky-mark #:right-sticky-mark
- #:standard-left-sticky-mark #:standard-right-sticky-mark
- #:clone-mark
- #:no-such-offset #:offset-before-beginning #:offset-after-end
- #:invalid-motion #:motion-before-beginning #:motion-after-end
- #:size #:number-of-lines
- #:offset #:mark< #:mark<= #:mark= #:mark> #:mark>=
- #:forward-object
- #:backward-object
- #:forward-line-start #:backward-line-start
- #:forward-line-end #:backward-line-end
- #:beginning-of-buffer #:end-of-buffer
- #:beginning-of-buffer-p #:end-of-buffer-p
- #:beginning-of-line #:end-of-line
- #:beginning-of-line-p #:end-of-line-p
- #:buffer-line-number #:buffer-column-number
- #:line-number #:column-number
- #:insert-buffer-object #:insert-buffer-sequence
- #:buffer-substring
- #:insert-object #:insert-sequence
- #:delete-buffer-range #:delete-range
- #:delete-region
- #:buffer-object #:buffer-sequence
- #:object-before #:object-after #:region-to-sequence
- #:low-mark #:high-mark #:modified-p #:clear-modify
- #:binseq-buffer #:obinseq-buffer #:binseq2-buffer
- #:persistent-left-sticky-mark #:persistent-right-sticky-mark
- #:persistent-left-sticky-line-mark #:persistent-right-sticky-line-mark
- #:p-line-mark-mixin #:buffer-line-offset
- #:delegating-buffer #:implementation)
- (:documentation "An implementation of the Climacs buffer
- protocol. This package is quite low-level, not syntax-aware,
- not CLIM-aware and not user-oriented at all."))
-
-(defpackage :climacs-kill-ring
- (:use :clim-lisp :flexichain)
- (:export #:kill-ring
- #:empty-kill-ring
- #:kill-ring-length #:kill-ring-max-size
- #:append-next-p
- #:reset-yank-position #:rotate-yank-position #:kill-ring-yank
- #:kill-ring-standard-push #:kill-ring-concatenating-push
- #:kill-ring-reverse-concatenating-push
- #:*kill-ring*)
- (:documentation "An implementation of a kill ring."))
-
-(defpackage :climacs-base
- (:use :clim-lisp :climacs-buffer :climacs-kill-ring :esa-buffer :climacs-utils)
- (:export #:as-offsets
- #:do-buffer-region
- #:do-buffer-region-lines
- #:previous-line #:next-line
- #:open-line
- #:delete-line
- #:empty-line-p
- #:line-indentation
- #:buffer-display-column
- #:number-of-lines-in-region
- #:constituentp
- #:just-n-spaces
- #:move-to-column
- #:buffer-whitespacep
- #:buffer-region-case
- #:name-mixin #:name
- #:buffer-looking-at #:looking-at
- #:buffer-search-forward #:buffer-search-backward
- #:buffer-re-search-forward #:buffer-re-search-backward
- #:search-forward #:search-backward
- #:re-search-forward #:re-search-backward
- #:downcase-buffer-region #:downcase-region
- #:upcase-buffer-region #:upcase-region
- #:capitalize-buffer-region #:capitalize-region
- #:tabify-region #:untabify-region)
- (:documentation "Basic functionality built on top of the buffer
- protocol. Here is where we define slightly higher level
- functions, that can be directly implemented in terms of the
- buffer protocol, but that are not, strictly speaking, part of
- that protocol. The functions in this package are not
- syntax-aware, and are thus limited in what they can do. They
- percieve the buffer as little more than a sequence of
- characters."))
-
-(defpackage :climacs-abbrev
- (:use :clim-lisp :clim :climacs-buffer :climacs-base)
- (:export #:abbrev-expander #:dictionary-abbrev-expander #:dictionary
- #:expand-abbrev #:abbrev-mixin #:possibly-expand-abbrev
- #:add-abbrev))
-
-(defpackage :climacs-syntax
- (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain :climacs-utils)
- (:export #:syntax #:define-syntax #:*default-syntax*
- #:eval-option
- #:define-option-for-syntax
- #:current-attributes-for-syntax
- #:make-attribute-line
- #:syntax-from-name
- #:update-syntax #:update-syntax-for-display
- #:grammar #:grammar-rule #:add-rule
- #:parser #:initial-state
- #:advance-parse
- #:parse-tree #:start-offset #:end-offset
- #:lexer #:nb-lexemes #:lexeme #:insert-lexeme
- #:incremental-lexer #:next-lexeme
- #:delete-invalid-lexemes #:inter-lexeme-object-p
- #:skip-inter-lexeme-objects #:update-lex
- #:parse-stack-top #:target-parse-tree #:parse-state-empty-p
- #:parse-stack-next #:parse-stack-symbol
- #:parse-stack-parse-trees #:map-over-parse-trees
- #:no-such-operation #:no-expression
- #:name-for-info-pane
- #:display-syntax-name
- #:syntax-line-indentation
- #:forward-expression #:backward-expression
- #:eval-defun
- #:beginning-of-definition #:end-of-definition
- #:redisplay-pane-with-syntax
- #:backward-paragraph #:forward-paragraph
- #:backward-sentence #:forward-sentence
- #:forward-list #:backward-list
- #:down-list #:up-list
- #:backward-down-list #:backward-up-list
- #:syntax-line-comment-string
- #:line-comment-region #:comment-region
- #:line-uncomment-region #:uncomment-region
- #:word-constituentp
- #:whitespacep
- #:page-delimiter
- #:paragraph-delimiter)
- (:documentation "The Climacs syntax protocol. Contains
- functions that can be used to implement higher-level operations
- on buffer contents."))
-
-(defpackage :undo
- (:use :clim-lisp)
- (:export #:no-more-undo
- #:undo-tree #:standard-undo-tree
- #:undo-record #:standard-undo-record
- #:add-undo #:flip-undo-record #:undo #:redo))
-
-(defpackage :climacs-pane
- (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev
- :climacs-syntax :flexichain :undo :esa-buffer :esa-io :climacs-utils)
- (:export #:climacs-buffer #:needs-saving
- #:filepath #:file-saved-p #:file-write-time
- #:read-only-p #:buffer-read-only
- #:climacs-pane #:point #:mark
- #:clear-cache
- #:redisplay-pane #:full-redisplay
- #:display-cursor
- #:display-region
- #:offset-to-screen-position
- #:page-down #:page-up
- #:top #:bot
- #:tab-space-count #:space-width #:tab-width
- #:indent-tabs-mode
- #:auto-fill-mode #:auto-fill-column
- #:isearch-state #:search-string #:search-mark
- #:search-forward-p #:search-success-p
- #:isearch-mode #:isearch-states #:isearch-previous-string
- #:query-replace-state #:string1 #:string2 #:buffers #:mark
- #:query-replace-mode
- #:region-visible-p
- #:with-undo
- #:url
- #:climacs-textual-view #:+climacs-textual-view+))
-
-(defpackage :climacs-motion
- (:use :clim-lisp :climacs-base :climacs-buffer :climacs-syntax)
- (:export #:forward-to-word-boundary #:backward-to-word-boundary
- #:define-motion-fns
- #:beep-limit-action #:revert-limit-action #:error-limit-action
- #:motion-limit-error
- #:make-diligent-motor
-
- ;; Lines
- #:forward-one-line
- #:backward-one-line
- #:forward-line
- #:backward-line
-
- ;; Words
- #:forward-one-word
- #:backward-one-word
- #:forward-word
- #:backward-word
-
- ;; Pages
- #:forward-one-page
- #:backward-one-page
- #:forward-page
- #:backward-page
-
- ;; Expressions
- #:forward-one-expression
- #:backward-one-expression
- #:forward-expression
- #:backward-expression
-
- ;; Definitions
- #:forward-one-definition
- #:backward-one-definition
- #:forward-definition
- #:backward-definition
-
- ;; Up
- #:forward-one-up
- #:backward-one-up
- #:forward-up
- #:backward-up
-
- ;; Down
- #:forward-one-down
- #:backward-one-down
- #:forward-down
- #:backward-down
-
- ;; Paragraphs
- #:forward-one-paragraph
- #:backward-one-paragraph
- #:forward-paragraph
- #:backward-paragraph
-
- ;; Sentences
- #:forward-one-sentence
- #:backward-one-sentence
- #:forward-sentence
- #:backward-sentence)
- (:documentation "Functions and facilities for moving a mark
- around by syntactical elements. The functions in this package
- are syntax-aware, and their behavior is based on the semantics
- defined by the syntax of the buffer, that the mark they are
- manipulating belong to. These functions are also directly used
- to implement the motion commands."))
-
-(defpackage :climacs-editing
- (:use :clim-lisp :climacs-base :climacs-buffer
- :climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring)
- (:export #:transpose-objects
-
- ;; Lines
- #:forward-delete-line #:backward-delete-line
- #:forward-kill-line #:backward-kill-line
- #:transpose-lines
- #:forward-delete-line-start #:backward-delete-line-start
- #:forward-kill-line-start #:backward-kill-line-start
- #:transpose-line-starts
-
- ;; Words
- #:forward-delete-word #:backward-delete-word
- #:forward-kill-word #:backward-kill-word
- #:transpose-words
-
- ;; Pages
- #:forward-delete-page #:backward-delete-page
- #:forward-kill-page #:backward-kill-page
- #:transpose-page
-
- ;; Expressions
- #:forward-delete-expression #:backward-delete-expression
- #:forward-kill-expression #:backward-kill-expression
- #:transpose-expressions
-
- ;; Definitions
- #:forward-delete-definition #:backward-delete-definition
- #:forward-kill-definition #:backward-kill-definition
- #:transpose-definitions
-
- ;; Paragraphs
- #:forward-delete-paragraph #:backward-delete-paragraph
- #:forward-kill-paragraph #:backward-kill-paragraph
- #:transpose-paragraphs
-
- ;; Sentences
- #:forward-delete-sentence #:backward-delete-sentence
- #:forward-kill-sentence #:backward-kill-sentence
- #:transpose-sentences)
- (:documentation "Functions and facilities for changing the
- buffer contents by syntactical elements. The functions in this package
- are syntax-aware, and their behavior is based on the semantics
- defined by the syntax of the buffer, that the mark they are
- manipulating belong to. These functions are also directly used
- to implement the editing commands."))
-
-(defpackage :climacs-fundamental-syntax
- (:use :clim-lisp :clim :climacs-buffer :climacs-base
- :climacs-syntax :flexichain :climacs-pane)
- (:export #:fundamental-syntax))
-
(defpackage :climacs-gui
- (:use :clim-lisp :clim :climacs-buffer :climacs-base
- :climacs-abbrev :climacs-syntax :climacs-motion
- :climacs-kill-ring :climacs-pane :clim-extensions
- :undo :esa :climacs-editing :climacs-motion :esa-buffer :esa-io)
+ (:use :clim-lisp :clim :drei-buffer :drei-base
+ :drei-abbrev :drei-syntax :drei-motion
+ :drei-kill-ring :drei :clim-extensions
+ :drei-undo :esa :drei-editing :drei-motion
+ :esa-buffer :esa-io :esa-utils)
;;(:import-from :lisp-string)
(:export #:climacs ; Frame.
- #:extended-pane
+ #:climacs-buffer #:external-format
+ #:climacs-pane
#:climacs-info-pane
#:typeout-pane
#:kill-ring
;; GUI functions follow.
- #:current-window
- #:current-point
- #:current-buffer
- #:current-point
- #:current-mark
#:any-buffer
#:point
#:syntax
@@ -352,7 +49,6 @@
#:buffers
#:active-group
#:groups
- #:insert-character
#:display-window
#:split-window
#:typeout-window
@@ -368,53 +64,26 @@
#:*mini-bg-color*
#:*mini-fg-color*
#:*with-scrollbars*
+ #:*default-external-format*
;; The command tables
#:global-climacs-table #:keyboard-macro-table #:climacs-help-table
- #:base-table #:buffer-table #:case-table #:comment-table
- #:deletion-table #:development-table #:editing-table
- #:fill-table #:indent-table #:info-table #:marking-table
- #:movement-table #:pane-table #:search-table #:self-insert-table
- #:window-table
-
- ;; Other stuff
- #:dabbrev-expansion-mark
- #:original-prefix
- #:prefix-start-offset
- #:overwrite-mode
- #:goal-column
- ))
+ #:base-table #:buffer-table #:case-table
+ #:development-table
+ #:info-table #:pane-table
+ #:window-table))
(defpackage :climacs-core
- (:use :clim-lisp :climacs-base :climacs-buffer :climacs-fundamental-syntax
- :climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring
- :climacs-editing :climacs-gui :clim :climacs-abbrev :esa :esa-buffer :esa-io
- :climacs-utils)
+ (:use :clim-lisp :drei-base :drei-buffer :drei-fundamental-syntax
+ :drei-syntax :drei-motion :drei :drei-kill-ring
+ :drei-editing :climacs-gui :clim :drei-abbrev :esa :esa-buffer :esa-io
+ :esa-utils :drei-core :flexi-streams)
(:export #:display-string
#:object-equal
#:object=
#:no-upper-p
#:case-relevant-test
- #:goto-position
- #:goto-line
-
- #:possibly-fill-line
- #:insert-character
- #:back-to-indentation
- #:delete-horizontal-space
- #:indent-current-line
- #:insert-pair
-
- #:downcase-word #:upcase-word #:capitalize-word
-
- #:indent-region
- #:fill-line #:fill-region
-
- #:indent-line #:delete-indentation
[76 lines skipped]
--- /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2006/09/02 21:43:56 1.29
+++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2006/11/12 16:06:06 1.30
@@ -77,18 +77,18 @@
(defclass start-lexeme (prolog-lexeme) ())
-(defgeneric display-parse-tree (entity syntax pane))
+(defgeneric display-parse-tree (entity syntax stream drei))
(defclass layout-text (prolog-nonterminal)
((comment :initarg :comment :accessor comment :initform nil)
(cont :initarg :cont :accessor cont)))
(defmethod display-parse-tree
- ((entity layout-text) (syntax prolog-syntax) pane)
+ ((entity layout-text) (syntax prolog-syntax) (stream extended-output-stream) (drei drei))
(when (cont entity)
- (display-parse-tree (cont entity) syntax pane))
+ (display-parse-tree (cont entity) syntax stream drei))
(when (comment entity)
- (with-drawing-options (pane :ink (make-rgb-color 0.7 0.0 0.0))
- (display-parse-tree (comment entity) syntax pane))))
+ (with-drawing-options (stream :ink (make-rgb-color 0.7 0.0 0.0))
+ (display-parse-tree (comment entity) syntax stream drei))))
(defgeneric syntactic-lexeme (thing))
(defmethod syntactic-lexeme ((lexeme prolog-lexeme))
@@ -103,12 +103,12 @@
((layout-text :initarg :layout-text :accessor layout-text :initform nil)
(syntactic-lexeme :initarg :syntactic-lexeme :accessor syntactic-lexeme)))
(defmethod display-parse-tree
- ((entity ,name) (syntax prolog-syntax) pane)
+ ((entity ,name) (syntax prolog-syntax) (stream extended-output-stream) (drei drei))
(when (layout-text entity)
(display-parse-tree
- (layout-text entity) syntax pane))
+ (layout-text entity) syntax stream drei))
(display-parse-tree
- (syntactic-lexeme entity) syntax pane))
+ (syntactic-lexeme entity) syntax stream drei))
(define-prolog-rule (,name -> (,(f name)))
(make-instance ',name :syntactic-lexeme ,(f name)))
(define-prolog-rule (,name -> (layout-text ,(f name)))
@@ -143,8 +143,9 @@
;;; expression here.
(defclass open-ct (prolog-nonterminal)
((syntactic-lexeme :initarg :syntactic-lexeme :accessor syntactic-lexeme)))
-(defmethod display-parse-tree ((entity open-ct) (syntax prolog-syntax) pane)
- (display-parse-tree (syntactic-lexeme entity) syntax pane))
+(defmethod display-parse-tree ((entity open-ct) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (syntactic-lexeme entity) syntax stream drei))
(define-prolog-rule (open-ct -> (open-ct-lexeme))
(make-instance 'open-ct :syntactic-lexeme open-ct-lexeme))
@@ -409,18 +410,21 @@
(text-rest :initarg :text-rest :accessor text-rest)))
(defmethod display-parse-tree
- ((entity empty-prolog-text) (syntax prolog-syntax) pane)
- (declare (ignore pane))
+ ((entity empty-prolog-text) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (declare (ignore stream drei))
nil)
(defmethod display-parse-tree
- ((entity clause-prolog-text) (syntax prolog-syntax) pane)
- (display-parse-tree (text-rest entity) syntax pane)
- (display-parse-tree (clause entity) syntax pane))
-(defmethod display-parse-tree
- ((entity directive-prolog-text) (syntax prolog-syntax) pane)
- (display-parse-tree (text-rest entity) syntax pane)
- (with-text-face (pane :italic)
- (display-parse-tree (directive entity) syntax pane)))
+ ((entity clause-prolog-text) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (text-rest entity) syntax stream drei)
+ (display-parse-tree (clause entity) syntax stream drei))
+(defmethod display-parse-tree
+ ((entity directive-prolog-text) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (text-rest entity) syntax stream drei)
+ (with-text-face (stream :italic)
+ (display-parse-tree (directive entity) syntax stream drei)))
(defclass directive (prolog-nonterminal)
((directive-term :initarg :directive-term :accessor directive-term)
@@ -433,19 +437,23 @@
(defclass clause-term (prolog-nonterminal)
((term :initarg :term :accessor term)))
-(defmethod display-parse-tree ((entity directive) (syntax prolog-syntax) pane)
- (with-text-face (pane :italic)
- (display-parse-tree (directive-term entity) syntax pane))
- (display-parse-tree (end entity) syntax pane))
-(defmethod display-parse-tree
- ((entity directive-term) (syntax prolog-syntax) pane)
- (display-parse-tree (term entity) syntax pane))
-(defmethod display-parse-tree ((entity clause) (syntax prolog-syntax) pane)
- (display-parse-tree (clause-term entity) syntax pane)
- (display-parse-tree (end entity) syntax pane))
-(defmethod display-parse-tree
- ((entity clause-term) (syntax prolog-syntax) pane)
- (display-parse-tree (term entity) syntax pane))
+(defmethod display-parse-tree ((entity directive) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (with-text-face (stream :italic)
+ (display-parse-tree (directive-term entity) syntax stream drei))
+ (display-parse-tree (end entity) syntax stream drei))
+(defmethod display-parse-tree
+ ((entity directive-term) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (term entity) syntax stream drei))
+(defmethod display-parse-tree ((entity clause) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (clause-term entity) syntax stream drei)
+ (display-parse-tree (end entity) syntax stream drei))
+(defmethod display-parse-tree
+ ((entity clause-term) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (term entity) syntax stream drei))
(defgeneric functor (term))
(defgeneric arity (term))
@@ -514,57 +522,67 @@
2)
(defmethod display-parse-tree
- ((entity constant-term) (syntax prolog-syntax) pane)
+ ((entity constant-term) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
;; FIXME: this is so not the right thing.
(cond
((consp (value entity))
- (display-parse-tree (first (value entity)) syntax pane)
- (display-parse-tree (second (value entity)) syntax pane))
- (t (display-parse-tree (value entity) syntax pane))))
+ (display-parse-tree (first (value entity)) syntax stream drei)
+ (display-parse-tree (second (value entity)) syntax stream drei))
+ (t (display-parse-tree (value entity) syntax stream drei))))
(defmethod display-parse-tree
- ((entity variable-term) (syntax prolog-syntax) pane)
- (with-drawing-options (pane :ink (make-rgb-color 0.7 0.7 0.0))
- (display-parse-tree (name entity) syntax pane)))
+ ((entity variable-term) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (with-drawing-options (stream :ink (make-rgb-color 0.7 0.7 0.0))
+ (display-parse-tree (name entity) syntax stream drei)))
(defmethod display-parse-tree
- ((entity functional-compound-term) (syntax prolog-syntax) pane)
- (with-drawing-options (pane :ink (make-rgb-color 0.9 0 0.9))
- (display-parse-tree (functor entity) syntax pane))
- (display-parse-tree (open-ct entity) syntax pane)
- (display-parse-tree (arg-list entity) syntax pane)
- (display-parse-tree (close entity) syntax pane))
-(defmethod display-parse-tree
- ((entity bracketed-term) (syntax prolog-syntax) pane)
- (display-parse-tree (open entity) syntax pane)
- (display-parse-tree (term entity) syntax pane)
- (display-parse-tree (close entity) syntax pane))
-(defmethod display-parse-tree
- ((entity binary-operator-compound-term) (syntax prolog-syntax) pane)
- (display-parse-tree (left entity) syntax pane)
- (display-parse-tree (operator entity) syntax pane)
- (display-parse-tree (right entity) syntax pane))
-(defmethod display-parse-tree
- ((entity prefix-operator-compound-term) (syntax prolog-syntax) pane)
- (display-parse-tree (operator entity) syntax pane)
- (display-parse-tree (right entity) syntax pane))
-(defmethod display-parse-tree
- ((entity postfix-operator-compound-term) (syntax prolog-syntax) pane)
- (display-parse-tree (left entity) syntax pane)
- (display-parse-tree (operator entity) syntax pane))
-(defmethod display-parse-tree
- ((entity list-compound-term) (syntax prolog-syntax) pane)
- (with-drawing-options (pane :ink (make-rgb-color 0.0 0.0 0.8))
- (display-parse-tree ([ entity) syntax pane)
- (display-parse-tree (items entity) syntax pane)
- (display-parse-tree (] entity) syntax pane)))
-(defmethod display-parse-tree
- ((entity curly-compound-term) (syntax prolog-syntax) pane)
- (display-parse-tree ({ entity) syntax pane)
- (display-parse-tree (term entity) syntax pane)
- (display-parse-tree (} entity) syntax pane))
-(defmethod display-parse-tree
- ((entity char-code-list-compound-term) (syntax prolog-syntax) pane)
- (with-drawing-options (pane :ink (make-rgb-color 0.0 0.6 0.0))
- (display-parse-tree (ccl entity) syntax pane)))
+ ((entity functional-compound-term) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (with-drawing-options (stream :ink (make-rgb-color 0.9 0 0.9))
+ (display-parse-tree (functor entity) syntax stream drei))
+ (display-parse-tree (open-ct entity) syntax stream drei)
+ (display-parse-tree (arg-list entity) syntax stream drei)
+ (display-parse-tree (close entity) syntax stream drei))
+(defmethod display-parse-tree
+ ((entity bracketed-term) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (open entity) syntax stream drei)
+ (display-parse-tree (term entity) syntax stream drei)
+ (display-parse-tree (close entity) syntax stream drei))
+(defmethod display-parse-tree
+ ((entity binary-operator-compound-term) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (left entity) syntax stream drei)
+ (display-parse-tree (operator entity) syntax stream drei)
+ (display-parse-tree (right entity) syntax stream drei))
+(defmethod display-parse-tree
+ ((entity prefix-operator-compound-term) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (operator entity) syntax stream drei)
+ (display-parse-tree (right entity) syntax stream drei))
+(defmethod display-parse-tree
+ ((entity postfix-operator-compound-term) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (left entity) syntax stream drei)
+ (display-parse-tree (operator entity) syntax stream drei))
+(defmethod display-parse-tree
+ ((entity list-compound-term) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (with-drawing-options (stream :ink (make-rgb-color 0.0 0.0 0.8))
+ (display-parse-tree ([ entity) syntax stream drei)
+ (display-parse-tree (items entity) syntax stream drei)
+ (display-parse-tree (] entity) syntax stream drei)))
+(defmethod display-parse-tree
+ ((entity curly-compound-term) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree ({ entity) syntax stream drei)
+ (display-parse-tree (term entity) syntax stream drei)
+ (display-parse-tree (} entity) syntax stream drei))
+(defmethod display-parse-tree
+ ((entity char-code-list-compound-term) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (with-drawing-options (stream :ink (make-rgb-color 0.0 0.6 0.0))
+ (display-parse-tree (ccl entity) syntax stream drei)))
(defclass atom (prolog-nonterminal)
((value :initarg :value :accessor value)))
@@ -591,15 +609,18 @@
(defmethod canonical-name ((thing curly-brackets))
;; FIXME: see comment in CANONICAL-NAME (EMPTY-LIST)
"{}")
-(defmethod display-parse-tree ((entity atom) (syntax prolog-syntax) pane)
- (display-parse-tree (value entity) syntax pane))
-(defmethod display-parse-tree ((entity empty-list) (syntax prolog-syntax) pane)
- (display-parse-tree ([ entity) syntax pane)
- (display-parse-tree (] entity) syntax pane))
-(defmethod display-parse-tree
- ((entity curly-brackets) (syntax prolog-syntax) pane)
- (display-parse-tree ({ entity) syntax pane)
- (display-parse-tree (} entity) syntax pane))
+(defmethod display-parse-tree ((entity atom) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (value entity) syntax stream drei))
+(defmethod display-parse-tree ((entity empty-list) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree ([ entity) syntax stream drei)
+ (display-parse-tree (] entity) syntax stream drei))
+(defmethod display-parse-tree
+ ((entity curly-brackets) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree ({ entity) syntax stream drei)
+ (display-parse-tree (} entity) syntax stream drei))
(defclass arg-list (prolog-nonterminal)
((exp :initarg :exp :accessor exp)))
@@ -617,13 +638,15 @@
(exp a)
(arg-list-nth (1- n) (arg-list a))))
-(defmethod display-parse-tree ((entity arg-list) (syntax prolog-syntax) pane)
- (display-parse-tree (exp entity) syntax pane))
-(defmethod display-parse-tree
- ((entity arg-list-pair) (syntax prolog-syntax) pane)
- (display-parse-tree (exp entity) syntax pane)
- (display-parse-tree (comma entity) syntax pane)
- (display-parse-tree (arg-list entity) syntax pane))
+(defmethod display-parse-tree ((entity arg-list) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (exp entity) syntax stream drei))
+(defmethod display-parse-tree
+ ((entity arg-list-pair) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (exp entity) syntax stream drei)
+ (display-parse-tree (comma entity) syntax stream drei)
+ (display-parse-tree (arg-list entity) syntax stream drei))
(defclass exp (prolog-nonterminal) ())
(defclass exp-atom (exp)
@@ -631,10 +654,12 @@
(defclass exp-term (exp)
((term :initarg :term :accessor term)))
-(defmethod display-parse-tree ((entity exp-atom) (syntax prolog-syntax) pane)
- (display-parse-tree (atom entity) syntax pane))
-(defmethod display-parse-tree ((entity exp-term) (syntax prolog-syntax) pane)
- (display-parse-tree (term entity) syntax pane))
+(defmethod display-parse-tree ((entity exp-atom) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (atom entity) syntax stream drei))
+(defmethod display-parse-tree ((entity exp-term) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (term entity) syntax stream drei))
(defclass lterm (term)
((term :initarg :term :accessor term)))
@@ -645,8 +670,9 @@
(defmethod arity ((l lterm))
(arity (term l)))
-(defmethod display-parse-tree ((entity lterm) (syntax prolog-syntax) pane)
- (display-parse-tree (term entity) syntax pane))
+(defmethod display-parse-tree ((entity lterm) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (term entity) syntax stream drei))
;;; FIXME: the need for these is because it is a protocol violation to
;;; create nested nonterminals from one rule.
@@ -671,18 +697,21 @@
1)
(defmethod display-parse-tree
- ((entity binary-operator-compound-lterm) (syntax prolog-syntax) pane)
- (display-parse-tree (left entity) syntax pane)
- (display-parse-tree (operator entity) syntax pane)
- (display-parse-tree (right entity) syntax pane))
-(defmethod display-parse-tree
- ((entity prefix-operator-compound-lterm) (syntax prolog-syntax) pane)
- (display-parse-tree (operator entity) syntax pane)
- (display-parse-tree (right entity) syntax pane))
-(defmethod display-parse-tree
- ((entity postfix-operator-compound-lterm) (syntax prolog-syntax) pane)
- (display-parse-tree (left entity) syntax pane)
- (display-parse-tree (operator entity) syntax pane))
+ ((entity binary-operator-compound-lterm) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (left entity) syntax stream drei)
+ (display-parse-tree (operator entity) syntax stream drei)
+ (display-parse-tree (right entity) syntax stream drei))
+(defmethod display-parse-tree
+ ((entity prefix-operator-compound-lterm) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (operator entity) syntax stream drei)
+ (display-parse-tree (right entity) syntax stream drei))
+(defmethod display-parse-tree
+ ((entity postfix-operator-compound-lterm) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (left entity) syntax stream drei)
+ (display-parse-tree (operator entity) syntax stream drei))
(defclass op (prolog-nonterminal)
((name :initarg :name :accessor name)
@@ -694,8 +723,9 @@
(defclass binary-op (op) ())
(defclass postfix-op (op) ())
-(defmethod display-parse-tree ((entity op) (syntax prolog-syntax) pane)
- (display-parse-tree (name entity) syntax pane))
+(defmethod display-parse-tree ((entity op) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (name entity) syntax stream drei))
(defclass items (prolog-nonterminal)
((exp :initarg :exp :accessor exp)))
@@ -706,18 +736,21 @@
((comma :initarg :comma :accessor comma)
(tlist :initarg :tlist :accessor tlist)))
-(defmethod display-parse-tree ((entity items) (syntax prolog-syntax) pane)
- (display-parse-tree (exp entity) syntax pane))
-(defmethod display-parse-tree
- ((entity items-pair) (syntax prolog-syntax) pane)
- (display-parse-tree (exp entity) syntax pane)
- (display-parse-tree (htsep entity) syntax pane)
- (display-parse-tree (texp entity) syntax pane))
-(defmethod display-parse-tree
- ((entity items-list) (syntax prolog-syntax) pane)
- (display-parse-tree (exp entity) syntax pane)
- (display-parse-tree (comma entity) syntax pane)
- (display-parse-tree (tlist entity) syntax pane))
+(defmethod display-parse-tree ((entity items) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (exp entity) syntax stream drei))
+(defmethod display-parse-tree
+ ((entity items-pair) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (exp entity) syntax stream drei)
+ (display-parse-tree (htsep entity) syntax stream drei)
+ (display-parse-tree (texp entity) syntax stream drei))
+(defmethod display-parse-tree
+ ((entity items-list) (syntax prolog-syntax)
+ (stream extended-output-stream) (drei drei))
+ (display-parse-tree (exp entity) syntax stream drei)
+ (display-parse-tree (comma entity) syntax stream drei)
+ (display-parse-tree (tlist entity) syntax stream drei))
;;; FIXME FIXME FIXME!!!
;;;
@@ -1093,7 +1126,7 @@
(defmethod update-syntax-for-display (buffer (syntax prolog-syntax) top bot)
[261 lines skipped]
--- /project/climacs/cvsroot/climacs/prolog2paiprolog.lisp 2006/08/20 13:06:38 1.2
+++ /project/climacs/cvsroot/climacs/prolog2paiprolog.lisp 2006/11/12 16:06:06 1.3
@@ -53,13 +53,13 @@
buffer))
(defun buffer->paiprolog (buffer)
- (let ((lexemes (climacs-syntax::lexemes (lexer (syntax buffer))))
+ (let ((lexemes (drei-syntax::lexemes (lexer (syntax buffer))))
(expressions '()))
(dotimes (i (flexichain:nb-elements lexemes) (nreverse expressions))
(let ((lexeme (flexichain:element* lexemes i)))
(when (typep lexeme 'end-lexeme)
(with-hash-table-iterator
- (next-entry (climacs-syntax::parse-trees (slot-value lexeme 'state)))
+ (next-entry (drei-syntax::parse-trees (slot-value lexeme 'state)))
(loop
(multiple-value-bind (more from-state items)
(next-entry)
--- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/09/12 19:49:18 1.15
+++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/11/12 16:06:06 1.16
@@ -1,4 +1,4 @@
-;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
+;;; -*- Mode: Lisp; Package: CLIMACS-COMMANDS -*-
;;; (c) copyright 2004-2005 by
;;; Robert Strandh (strandh(a)labri.fr)
@@ -24,483 +24,15 @@
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
-;;; Search commands for the Climacs editor.
+;;; Search commands for Climacs.
(in-package :climacs-commands)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
-;;; String search
-
-(define-command (com-string-search :name t :command-table search-table)
- ((string 'string :prompt "String Search"))
- "Prompt for a string and search forward for it.
-If found, leaves point after string. If not, leaves point where it is."
- (let* ((pane (current-window))
- (point (point pane)))
- (search-forward point string :test (case-relevant-test string))))
-
-(define-command (com-reverse-string-search :name t :command-table search-table)
- ((string 'string :prompt "Reverse String Search"))
- "Prompt for a string and search backward for it.
-If found, leaves point before string. If not, leaves point where it is."
- (let* ((pane (current-window))
- (point (point pane)))
- (search-backward point string :test (case-relevant-test string))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Word search
-
-(define-command (com-word-search :name t :command-table search-table)
- ((word 'string :prompt "Search word"))
- "Prompt for a whitespace delimited word and search forward for it.
-If found, leaves point after the word. If not, leaves point where it is."
- (let* ((pane (current-window))
- (point (point pane)))
- (climacs-base::search-word-forward point word)))
-
-(define-command (com-reverse-word-search :name t :command-table search-table)
- ((word 'string :prompt "Search word"))
- "Prompt for a whitespace delimited word and search backward for it.
-If found, leaves point before the word. If not, leaves point where it is."
- (let* ((pane (current-window))
- (point (point pane)))
- (climacs-base::search-word-backward point word)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Incremental search
-
-(make-command-table 'isearch-climacs-table :errorp nil)
-
-(defun isearch-command-loop (pane forwardp)
- (let ((point (point pane)))
- (unless (endp (isearch-states pane))
- (setf (isearch-previous-string pane)
- (search-string (first (isearch-states pane)))))
- (setf (isearch-mode pane) t)
- (setf (isearch-states pane)
- (list (make-instance 'isearch-state
- :search-string ""
- :search-mark (clone-mark point)
- :search-forward-p forwardp
- :search-success-p t)))
- (simple-command-loop 'isearch-climacs-table
- (isearch-mode pane)
- ((setf (isearch-mode pane) nil)))))
-
-(defun isearch-from-mark (pane mark string forwardp)
- (let* ((point (point pane))
- (mark2 (clone-mark mark))
- (success (funcall (if forwardp #'search-forward #'search-backward)
- mark2
- string
- :test (case-relevant-test string))))
- (when success
- (setf (offset point) (offset mark2)
- (offset mark) (if forwardp
- (- (offset mark2) (length string))
- (+ (offset mark2) (length string)))))
- (display-message "~:[Failing ~;~]Isearch~:[ backward~;~]: ~A"
- success forwardp (display-string string))
- (push (make-instance 'isearch-state
- :search-string string
- :search-mark mark
- :search-forward-p forwardp
- :search-success-p success)
- (isearch-states pane))
- (unless success
- (beep))))
-
-(define-command (com-isearch-forward :name t :command-table search-table) ()
- (display-message "Isearch: ")
- (isearch-command-loop (current-window) t))
-
-(set-key 'com-isearch-forward
- 'search-table
- '((#\s :control)))
-
-(define-command (com-isearch-backward :name t :command-table search-table) ()
- (display-message "Isearch backward: ")
- (isearch-command-loop (current-window) nil))
-
-(set-key 'com-isearch-backward
- 'search-table
- '((#\r :control)))
-
-(defun isearch-append-char (char)
- (let* ((pane (current-window))
- (states (isearch-states pane))
- (string (concatenate 'string
- (search-string (first states))
- (string char)))
- (mark (clone-mark (search-mark (first states))))
- (forwardp (search-forward-p (first states))))
- (unless (or forwardp (end-of-buffer-p mark))
- (incf (offset mark)))
- (isearch-from-mark pane mark string forwardp)))
-
-(define-command (com-isearch-append-char :name t :command-table isearch-climacs-table) ()
- (isearch-append-char *current-gesture*))
-
-(define-command (com-isearch-append-newline :name t :command-table isearch-climacs-table) ()
- (isearch-append-char #\Newline))
-
-(defun isearch-append-text (movement-function)
- (let* ((pane (current-window))
- (states (isearch-states pane))
- (buffer (buffer pane))
- (point (point pane))
- (start (clone-mark point))
- (mark (clone-mark (search-mark (first states))))
- (forwardp (search-forward-p (first states))))
- (funcall movement-function point)
- (let* ((start-offset (offset start))
- (point-offset (offset point))
- (string (concatenate 'string
- (search-string (first states))
- (buffer-substring buffer
- start-offset
- point-offset))))
- (unless (or forwardp (end-of-buffer-p mark))
- (incf (offset mark) (- point-offset start-offset)))
- (isearch-from-mark pane mark string forwardp))))
-
-(define-command (com-isearch-append-word :name t :command-table isearch-climacs-table) ()
- (let ((syntax (syntax (current-buffer *application-frame*))))
- (isearch-append-text #'(lambda (mark)
- (forward-word mark syntax)))))
-
-(define-command (com-isearch-append-line :name t :command-table isearch-climacs-table) ()
- (isearch-append-text #'end-of-line))
-
-(define-command (com-isearch-append-kill :name t :command-table isearch-climacs-table) ()
- (let* ((pane (current-window))
- (states (isearch-states pane))
- (yank (handler-case (kill-ring-yank *kill-ring*)
- (empty-kill-ring ()
- "")))
- (string (concatenate 'string
- (search-string (first states))
- yank))
- (mark (clone-mark (search-mark (first states))))
- (forwardp (search-forward-p (first states))))
- (unless (or forwardp (end-of-buffer-p mark))
- (incf (offset mark) (length yank)))
- (isearch-from-mark pane mark string forwardp)))
-
-(define-command (com-isearch-delete-char :name t :command-table isearch-climacs-table) ()
- (let* ((pane (current-window)))
- (cond ((null (second (isearch-states pane)))
- (display-message "Isearch: ")
- (beep))
- (t
- (pop (isearch-states pane))
- (loop until (endp (rest (isearch-states pane)))
- until (search-success-p (first (isearch-states pane)))
- do (pop (isearch-states pane)))
- (let ((state (first (isearch-states pane))))
- (setf (offset (point pane))
- (if (search-forward-p state)
- (+ (offset (search-mark state))
- (length (search-string state)))
- (- (offset (search-mark state))
- (length (search-string state)))))
- (display-message "Isearch~:[ backward~;~]: ~A"
- (search-forward-p state)
- (display-string (search-string state))))))))
-
-(define-command (com-isearch-search-forward :name t :command-table isearch-climacs-table) ()
- (let* ((pane (current-window))
- (point (point pane))
- (states (isearch-states pane))
- (string (if (null (second states))
- (isearch-previous-string pane)
- (search-string (first states))))
- (mark (clone-mark point)))
- (isearch-from-mark pane mark string t)))
-
-(define-command (com-isearch-search-backward :name t :command-table isearch-climacs-table) ()
- (let* ((pane (current-window))
- (point (point pane))
- (states (isearch-states pane))
- (string (if (null (second states))
- (isearch-previous-string pane)
- (search-string (first states))))
- (mark (clone-mark point)))
- (isearch-from-mark pane mark string nil)))
-
-(define-command (com-isearch-exit :name t :command-table isearch-climacs-table) ()
- (let* ((pane (current-window))
- (states (isearch-states pane))
- (string (search-string (first states)))
- (search-forward-p (search-forward-p (first states))))
- (setf (isearch-mode pane) nil)
- (when (string= string "")
- (execute-frame-command *application-frame*
- (funcall
- *partial-command-parser*
- (frame-command-table *application-frame*)
- (frame-standard-input *application-frame*)
- (if search-forward-p
- `(com-string-search ,*unsupplied-argument-marker*)
- `(com-reverse-string-search ,*unsupplied-argument-marker*))
- 0)))))
-
-(defun isearch-set-key (gesture command)
- (add-command-to-command-table command 'isearch-climacs-table
- :keystroke gesture :errorp nil))
-
-(loop for code from (char-code #\Space) to (char-code #\~)
- do (isearch-set-key (code-char code) 'com-isearch-append-char))
-
-(isearch-set-key '(#\Newline) 'com-isearch-exit)
-(isearch-set-key '(#\Backspace) 'com-isearch-delete-char)
-(isearch-set-key '(#\s :control) 'com-isearch-search-forward)
-(isearch-set-key '(#\r :control) 'com-isearch-search-backward)
-(isearch-set-key '(#\j :control) 'com-isearch-append-newline)
-(isearch-set-key '(#\w :control) 'com-isearch-append-word)
-(isearch-set-key '(#\y :control) 'com-isearch-append-line)
-(isearch-set-key '(#\y :meta) 'com-isearch-append-kill)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Unconditional replace
-
-(defun replace-one-string (mark length newstring &optional (use-region-case t))
- "Replace LENGTH objects at MARK with NEWSTRING,
-using the case of those objects if USE-REGION-CASE is true."
- (let* ((start (offset mark))
- (end (+ start length))
- (region-case (and use-region-case
- (buffer-region-case (buffer mark)
- start
- end))))
- (delete-range mark length)
- (insert-sequence mark newstring)
- (when (and use-region-case region-case)
- (let ((buffer (buffer mark))
- (end2 (+ start (length newstring))))
- (funcall (case region-case
- (:upper-case #'upcase-buffer-region)
- (:lower-case #'downcase-buffer-region)
- (:capitalized #'capitalize-buffer-region))
- buffer
- start
- end2)))))
-
-(define-command (com-replace-string :name t :command-table search-table)
- ()
- "Replace all occurrences of `string' with `newstring'."
- ;; We have to do it this way if we want to refer to STRING in NEWSTRING
- (let* ((string (accept 'string :prompt "Replace String"))
- (newstring (accept'string :prompt (format nil "Replace ~A with" string))))
- (loop with point = (point (current-window))
- with length = (length string)
- with use-region-case = (no-upper-p string)
- for occurrences from 0
- while (let ((offset-before (offset point)))
- (search-forward point string :test (case-relevant-test string))
- (/= (offset point) offset-before))
- do (backward-object point length)
- (replace-one-string point length newstring use-region-case)
- finally (display-message "Replaced ~A occurrence~:P" occurrences))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Query replace
-
-(make-command-table 'query-replace-climacs-table :errorp nil)
-
-(defun query-replace-find-next-match (state)
- (with-accessors ((string string1)
- (buffers buffers)
- (mark mark)) state
- (flet ((head-to-buffer (buffer)
- (switch-to-buffer (current-window) buffer)
- (setf mark (point (current-window)))
- (beginning-of-buffer mark)))
- (unless (eq (current-buffer) (first buffers))
- (when t buffers
- (head-to-buffer (first buffers))))
- (let ((offset-before (offset mark)))
- (search-forward mark string :test (case-relevant-test string))
- (or (/= (offset mark) offset-before)
- (unless (null (rest buffers))
- (pop buffers)
- (query-replace-find-next-match state)))))))
-
-(define-command (com-query-replace :name t :command-table search-table) ()
- (let* ((pane (current-window))
- (old-state (query-replace-state pane))
- (old-string1 (when old-state (string1 old-state)))
- (old-string2 (when old-state (string2 old-state)))
- (string1 (handler-case
- (if old-string1
- (accept 'string
- :prompt "Query Replace"
- :default old-string1
- :default-type 'string)
- (accept 'string :prompt "Query Replace"))
- (error () (progn (beep)
- (display-message "Empty string")
- (return-from com-query-replace nil)))))
- (string2 (handler-case
- (if old-string2
- (accept 'string
- :prompt (format nil "Replace ~A with"
- string1)
- :default old-string2
- :default-type 'string)
- (accept 'string
- :prompt (format nil "Replace ~A with" string1)))
- (error () (progn (beep)
- (display-message "Empty string")
- (return-from com-query-replace nil)))))
- (point (point pane))
- (occurrences 0))
- (declare (special string1 string2 occurrences))
- (with-group-buffers (buffers (get-active-group))
- (setf (query-replace-state pane) (make-instance 'query-replace-state
- :string1 string1
- :string2 string2
- :mark point
- :buffers buffers))
- (when (query-replace-find-next-match (query-replace-state pane))
- (setf (query-replace-mode pane) t)
- (display-message "Replace ~A with ~A:"
- string1 string2)
- (simple-command-loop 'query-replace-climacs-table
- (query-replace-mode pane)
- ((setf (query-replace-mode pane) nil))))
- (display-message "Replaced ~A occurrence~:P" occurrences))))
-
-(set-key 'com-query-replace
- 'search-table
- '((#\% :shift :meta)))
-
-(define-command (com-query-replace-replace :name t :command-table query-replace-climacs-table) ()
- (declare (special string1 string2 occurrences))
- (let* ((pane (current-window))
- (string1-length (length string1))
- (state (query-replace-state pane)))
- (backward-object (mark state) string1-length)
- (replace-one-string (mark state)
- string1-length
- string2
- (no-upper-p string1))
- (incf occurrences)
- (if (query-replace-find-next-match (query-replace-state pane))
- (display-message "Replace ~A with ~A:"
- string1 string2)
- (setf (query-replace-mode pane) nil))))
-
-(define-command (com-query-replace-replace-and-quit
- :name t
- :command-table query-replace-climacs-table)
- ()
- (declare (special string1 string2 occurrences))
- (let* ((pane (current-window))
- (string1-length (length string1))
- (state (query-replace-state pane)))
- (backward-object (mark state) string1-length)
- (replace-one-string (mark state)
- string1-length
- string2
- (no-upper-p string1))
- (incf occurrences)
- (setf (query-replace-mode pane) nil)))
[147 lines skipped]
--- /project/climacs/cvsroot/climacs/slidemacs-gui.lisp 2006/07/25 11:38:05 1.23
+++ /project/climacs/cvsroot/climacs/slidemacs-gui.lisp 2006/11/12 16:06:06 1.24
@@ -240,7 +240,7 @@
(pushnew (cons from to)
edges :test #'equal))))))
(possibly-capturing-and-flipping-output-twice
- pane (typep pane 'climacs-pane)
+ pane (typep pane 'drei-pane)
(format-graph-from-roots
roots
(lambda (node stream)
@@ -437,7 +437,7 @@
(defparameter *slidemacs-gui-ink* +black+)
-(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax slidemacs-gui-syntax) current-p)
+(defmethod redisplay-pane-with-syntax ((pane drei-pane) (syntax slidemacs-gui-syntax) current-p)
(with-drawing-options (pane :ink *slidemacs-gui-ink*)
(with-slots (top bot point) pane
(with-slots (lexer) syntax
@@ -530,11 +530,11 @@
(full-redisplay (climacs-gui::current-window)))
(define-command (com-first-talking-point :name t :command-table slidemacs-table) ()
- (climacs-commands::com-beginning-of-buffer)
+ (drei-commands::com-beginning-of-buffer)
(com-next-talking-point))
(define-command (com-last-talking-point :name t :command-table slidemacs-table) ()
- (climacs-commands::com-end-of-buffer)
+ (drei-commands::com-end-of-buffer)
(com-previous-talking-point))
(define-command (com-flip-slidemacs-syntax :name t :command-table slidemacs-table) ()
@@ -572,7 +572,7 @@
(define-command (com-postscript-print-presentation :name t :command-table slidemacs-table) ()
(let ((pane (climacs-gui::current-window)))
- (if (not (and (typep pane 'climacs-pane)
+ (if (not (and (typep pane 'drei-pane)
(typep (syntax (buffer pane)) 'slidemacs-gui-syntax)))
(beep)
(let ((file (accept 'pathname :prompt "Output to")))
--- /project/climacs/cvsroot/climacs/slidemacs.lisp 2006/09/02 21:43:56 1.11
+++ /project/climacs/cvsroot/climacs/slidemacs.lisp 2006/11/12 16:06:06 1.12
@@ -21,8 +21,8 @@
;;; Boston, MA 02111-1307 USA.
(defpackage :climacs-slidemacs-editor
- (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base
- :climacs-syntax :flexichain :climacs-pane :climacs-fundamental-syntax)
+ (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base
+ :drei-syntax :flexichain :drei :drei-fundamental-syntax)
(:export))
(in-package :climacs-slidemacs-editor)
@@ -387,23 +387,21 @@
(defun handle-whitespace (pane buffer start end)
(let ((space-width (space-width pane))
- (tab-width (tab-width pane)))
- (loop while (and (< start end)
- (whitespacep (syntax buffer)
- (buffer-object buffer start)))
- do (ecase (buffer-object buffer start)
- (#\Newline (terpri pane)
- (setf (aref *cursor-positions* (incf *current-line*))
- (multiple-value-bind (x y) (stream-cursor-position pane)
- (declare (ignore x))
- y)))
- (#\Space (stream-increment-cursor-position
- pane space-width 0))
- (#\Tab (let ((x (stream-cursor-position pane)))
- (stream-increment-cursor-position
- pane (- tab-width (mod x tab-width)) 0)))
- (#\Page nil))
- (incf start))))
+ (tab-width (tab-width pane)))
+ (with-sheet-medium (medium pane)
+ (with-accessors ((cursor-positions cursor-positions)) (syntax buffer)
+ (loop while (< start end)
+ do (case (buffer-object buffer start)
+ (#\Newline (record-line-vertical-offset pane (syntax buffer) (incf *current-line*))
+ (terpri pane)
+ (stream-increment-cursor-position
+ pane (first (aref cursor-positions 0)) 0))
+ ((#\Page #\Return #\Space) (stream-increment-cursor-position
+ pane space-width 0))
+ (#\Tab (let ((x (stream-cursor-position pane)))
+ (stream-increment-cursor-position
+ pane (- tab-width (mod x tab-width)) 0))))
+ (incf start))))))
(defvar *handle-whitespace* t)
@@ -419,11 +417,13 @@
(call-next-method)))
(call-next-method)))
-(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax slidemacs-editor-syntax) current-p)
+(defmethod display-drei-contents ((pane drei-pane) (drei drei) (syntax slidemacs-editor-syntax))
(with-slots (top bot) pane
- (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
- *current-line* 0
- (aref *cursor-positions* 0) (stream-cursor-position pane))
+ (with-accessors ((cursor-positions cursor-positions)) syntax
+ (setf cursor-positions (make-array (1+ (number-of-lines-in-region top bot))
+ :initial-element nil)
+ *current-line* 0
+ (aref cursor-positions 0) (multiple-value-list (stream-cursor-position pane))))
(with-slots (lexer) syntax
(let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
1.0)))
@@ -442,7 +442,7 @@
(loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
(not (parse-state-empty-p
(slot-value (lexeme lexer (1- start-token-index)) 'state))))
- do (decf start-token-index))
+ do (decf start-token-index))
(let ((*white-space-start* (offset top)))
;; display the parse tree if any
(unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
@@ -454,6 +454,4 @@
(loop while (< start-token-index end-token-index)
do (let ((token (lexeme lexer start-token-index)))
(display-parse-tree token syntax pane))
- (incf start-token-index))))))))
- (when (region-visible-p pane) (display-region pane syntax))
- (display-cursor pane syntax current-p)))
+ (incf start-token-index))))))))))
--- /project/climacs/cvsroot/climacs/text-syntax.lisp 2006/09/02 21:43:56 1.11
+++ /project/climacs/cvsroot/climacs/text-syntax.lisp 2006/11/12 16:06:06 1.12
@@ -52,7 +52,7 @@
;;; Right stickies at non whitespace characters preceeded by space and punctuation.
;;;
-(in-package :climacs-syntax) ;;; Put this in a separate package once it works
+(in-package :drei-syntax) ;;; Put this in a separate package once it works
(defun index-of-mark-after-offset (flexichain offset)
"Searches for the mark after `offset' in the marks stored in `flexichain'."
@@ -65,7 +65,7 @@
(setf low-position (floor (+ low-position 1 high-position) 2)))
finally (return low-position)))
-(define-syntax text-syntax (climacs-fundamental-syntax:fundamental-syntax)
+(define-syntax text-syntax (drei-fundamental-syntax:fundamental-syntax)
((paragraphs :initform (make-instance 'standard-flexichain))
(sentence-beginnings :initform (make-instance 'standard-flexichain))
(sentence-endings :initform (make-instance 'standard-flexichain)))
@@ -197,7 +197,7 @@
(loop with indentation = 0
with mark2 = (clone-mark mark)
until (beginning-of-buffer-p mark2)
- do (climacs-motion:backward-line mark2 syntax)
+ do (drei-motion:backward-line mark2 syntax)
(setf indentation (line-indentation mark2 tab-width))
while (empty-line-p mark2)
finally (return indentation)))
--- /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp 2006/09/02 21:43:56 1.7
+++ /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp 2006/11/12 16:06:06 1.8
@@ -21,8 +21,8 @@
;;; Boston, MA 02111-1307 USA.
(defpackage :climacs-ttcn3-syntax
- (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base
- :climacs-syntax :flexichain :climacs-pane :climacs-fundamental-syntax)
+ (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base
+ :drei-syntax :flexichain :drei :drei-fundamental-syntax)
(:export))
(in-package :climacs-ttcn3-syntax)
@@ -417,7 +417,7 @@
(when (and (end-offset entity) (mark> (end-offset entity) top))
(call-next-method))))
-(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax ttcn3-syntax) current-p)
+(defmethod redisplay-pane-with-syntax ((pane drei-pane) (syntax ttcn3-syntax) current-p)
(with-slots (top bot) pane
(setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
*current-line* 0
--- /project/climacs/cvsroot/climacs/window-commands.lisp 2006/07/24 16:33:16 1.10
+++ /project/climacs/cvsroot/climacs/window-commands.lisp 2006/11/12 16:06:06 1.11
@@ -96,8 +96,8 @@
(eq window (current-window)))
(setf (offset (mark window))
(click-to-offset window x y))
- (com-exchange-point-and-mark)
- (com-copy-region)))
+ (drei-commands::com-exchange-point-and-mark)
+ (drei-commands::com-copy-region)))
(define-presentation-to-command-translator blank-area-to-mouse-save
(blank-area com-mouse-save window-table :echo nil :gesture :select-other)
@@ -112,7 +112,7 @@
(other-window window)
(setf (offset (point window))
(click-to-offset window x y))
- (com-yank)))
+ (drei-commands::com-yank)))
(define-presentation-to-command-translator blank-area-to-yank-here
(blank-area com-yank-here window-table :echo nil :gesture :middle-button)
--- /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp 2006/11/12 16:06:07 NONE
+++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp 2006/11/12 16:06:07 1.1
;;; -*- Mode: Lisp; Package: CLIMACS-LISP-SYNTAX; -*-
;;; (c) copyright 2004-2005 by
;;; Robert Strandh (strandh(a)labri.fr)
;;; (c) copyright 2004-2005 by
;;; Elliott Johnson (ejohnson(a)fasl.info)
;;; (c) copyright 2005 by
;;; Matthieu Villeneuve (matthieu.villeneuve(a)free.fr)
;;; (c) copyright 2005 by
;;; Aleksandar Bakic (a_bakic(a)yahoo.com)
;;; (c) copyright 2006 by
;;; Troels Henriksen (athas(a)sigkill.dk)
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
;;; Commands specific to the Lisp syntax for Climacs.
(in-package :drei-lisp-syntax)
(make-command-table 'climacs-lisp-table
:errorp nil)
(defmethod additional-command-tables append ((frame climacs-gui:climacs) (command-table lisp-table))
'(climacs-lisp-table))
(define-command (com-package :name t :command-table climacs-lisp-table) ()
(let ((package (package-at-mark *current-syntax* *current-point*)))
(esa:display-message (format nil "~A" (if (packagep package)
(package-name package)
package)))))
(define-command (com-set-base :name t :command-table climacs-lisp-table)
((base '(integer 2 36)))
"Set the base for the current buffer."
(setf (base *current-syntax*) base))
(define-command (com-set-package :name t :command-table climacs-lisp-table)
((package 'package))
"Set the package for the current buffer."
(setf (option-specified-package *current-syntax*) package))
(define-command (com-macroexpand-1 :name t :command-table climacs-lisp-table)
()
"Macroexpand-1 the expression at point.
The expanded expression will be displayed in a
\"*Macroexpansion*\"-buffer."
(let*((token (expression-at-mark *current-point* *current-syntax*)))
(if token
(macroexpand-token *current-syntax* token)
(esa:display-message "Nothing to expand at point."))))
(define-command (com-macroexpand-all :name t :command-table climacs-lisp-table)
()
"Completely macroexpand the expression at point.
The expanded expression will be displayed in a
\"*Macroexpansion*\"-buffer."
(let ((token (expression-at-mark *current-point* *current-syntax*)))
(if token
(macroexpand-token *current-syntax* token t)
(esa:display-message "Nothing to expand at point."))))
(define-command (com-compile-and-load-file :name t :command-table climacs-lisp-table)
()
"Compile and load the current file.
Compiler notes will be displayed in a seperate buffer."
(compile-file-interactively *current-buffer* t))
(define-command (com-compile-file :name t :command-table climacs-lisp-table)
()
"Compile the file open in the current buffer.
This command does not load the file after it has been compiled."
(compile-file-interactively *current-buffer* nil))
(define-command (com-goto-location :name t :command-table climacs-lisp-table)
((note 'compiler-note))
"Move point to the part of a given file that caused the
compiler note.
If the file is not already open, a new buffer will be opened with
that file."
(goto-location (location note)))
(define-presentation-to-command-translator compiler-note-to-goto-location-translator
(compiler-note com-goto-location climacs-lisp-table)
(presentation)
(list (presentation-object presentation)))
(define-command (com-goto-xref :name t :command-table climacs-lisp-table)
((xref 'xref))
"Go to the referenced location of a code cross-reference."
(goto-location xref))
(define-presentation-to-command-translator xref-to-goto-location-translator
(xref com-goto-xref climacs-lisp-table)
(presentation)
(list (presentation-object presentation)))
(define-command (com-edit-this-definition :command-table climacs-lisp-table)
()
"Edit definition of the symbol at point.
If there is no symbol at point, this is a no-op."
(let* ((token (this-form *current-point* *current-syntax*))
(this-symbol (token-to-object *current-syntax* token)))
(when (and this-symbol (symbolp this-symbol))
(edit-definition this-symbol))))
(define-command (com-return-from-definition :name t :command-table climacs-lisp-table)
()
"Return point to where it was before the previous Edit
Definition command was issued."
(pop-find-definition-stack))
(esa:set-key 'com-eval-defun
'climacs-lisp-table
'((#\x :control :meta)))
(esa:set-key 'com-macroexpand-1
'climacs-lisp-table
'((#\c :control) (#\Newline)))
(esa:set-key 'com-macroexpand-all
'climacs-lisp-table
'((#\c :control) (#\m :control)))
(esa:set-key 'com-compile-and-load-file
'climacs-lisp-table
'((#\c :control) (#\k :control)))
(esa:set-key 'com-compile-file
'climacs-lisp-table
'((#\c :control) (#\k :meta)))
(esa:set-key 'com-edit-this-definition
'climacs-lisp-table
'((#\. :meta)))
(esa:set-key 'com-return-from-definition
'climacs-lisp-table
'((#\, :meta)))
--- /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2006/11/12 16:06:07 NONE
+++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2006/11/12 16:06:07 1.1
;;; -*- Mode: Lisp; Package: DREI-LISP-SYNTAX -*-
;;; (c) copyright 2005 by
;;; Robert Strandh (strandh(a)labri.fr)
;;; (c) copyright 2006 by
;;; Troels Henriksen (athas(a)sigkill.dk)
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
;;; Add Climacs-dependent functionality to the stock Lisp syntax.
(in-package :drei-lisp-syntax)
(defmethod frame-clear-completions ((frame climacs-gui:climacs))
(let ((completions-pane
(when (typep *application-frame* 'esa-frame-mixin)
(find "Completions" (windows *application-frame*)
:key #'pane-name
:test #'string=))))
(unless (null completions-pane)
(climacs-gui:delete-window completions-pane)
(setf completions-pane nil))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Compiler note hyperlinking
(defclass location ()()
(:documentation "The base for all locations."))
(defclass error-location (location)
((error-message :initarg :error-message :accessor error-message)))
(defclass actual-location (location)
((source-position :initarg :position :accessor source-position)
(snippet :initarg :snippet :accessor snippet :initform nil))
(:documentation "The base for all non-error locations."))
(defclass buffer-location (actual-location)
((buffer-name :initarg :buffer :accessor buffer-name)))
(defclass file-location (actual-location)
((file-name :initarg :file :accessor file-name)))
(defclass source-location (actual-location)
((source-form :initarg :source-form :accessor source-form)))
(defclass basic-position () ()
(:documentation "The base for all positions."))
(defclass char-position (basic-position)
((char-position :initarg :position :accessor char-position)
(align-p :initarg :align-p :initform nil :accessor align-p)))
(defun make-char-position (position-list)
(make-instance 'char-position :position (second position-list)
:align-p (third position-list)))
(defclass line-position (basic-position)
((start-line :initarg :line :accessor start-line)
(end-line :initarg :end-line :initform nil :accessor end-line)))
(defun make-line-position (position-list)
(make-instance 'line-position :line (second position-list)
:end-line (third position-list)))
(defclass function-name-position (basic-position)
((function-name :initarg :function-name)))
(defun make-function-name-position (position-list)
(make-instance 'function-name-position :function-name (second position-list)))
(defclass source-path-position (basic-position)
((path :initarg :source-path :accessor path)
(start-position :initarg :start-position :accessor start-position)))
(defun make-source-path-position (position-list)
(make-instance 'source-path-position :source-path (second position-list)
:start-position (third position-list)))
(defclass text-anchored-position (basic-position)
((start :initarg :text-anchored :accessor start)
(text :initarg :text :accessor text)
(delta :initarg :delta :accessor delta)))
(defun make-text-anchored-position (position-list)
(make-instance 'text-anchored-position :text-anchored (second position-list)
:text (third position-list)
:delta (fourth position-list)))
(defclass method-position (basic-position)
((name :initarg :method :accessor name)
(specializers :initarg :specializers :accessor specializers)
(qualifiers :initarg :qualifiers :accessor qualifiers)))
(defun make-method-position (position-list)
(make-instance 'method-position :method (second position-list)
:specializers (third position-list)
:qualifiers (last position-list)))
(defun make-location (location-list)
(ecase (first location-list)
(:error (make-instance 'error-location :error-message (second location-list)))
(:location
(destructuring-bind (l buf pos hints) location-list
(declare (ignore l))
(let ((location
(apply #'make-instance
(ecase (first buf)
(:file 'file-location)
(:buffer 'buffer-location)
(:source-form 'source-location))
buf))
(position
(funcall
(ecase (first pos)
(:position #'make-char-position)
(:line #'make-line-position)
(:function-name #'make-function-name-position)
(:source-path #'make-source-path-position)
(:text-anchored #'make-text-anchored-position)
(:method #'make-method-position))
pos)))
(setf (source-position location) position)
(when hints
(setf (snippet location) (rest hints)))
location)))))
(defmethod initialize-instance :after ((note compiler-note) &rest args)
(declare (ignore args))
(setf (location note) (make-location (location note))))
(defun show-note-counts (notes &optional seconds)
(loop with nerrors = 0
with nwarnings = 0
with nstyle-warnings = 0
with nnotes = 0
for note in notes
do (etypecase note
(error-compiler-note (incf nerrors))
(read-error-compiler-note (incf nerrors))
(warning-compiler-note (incf nwarnings))
(style-warning-compiler-note (incf nstyle-warnings))
(note-compiler-note (incf nnotes)))
finally
(esa:display-message "Compilation finished: ~D error~:P ~
~D warning~:P ~D style-warning~:P ~D note~:P ~
~@[[~D secs]~]"
nerrors nwarnings nstyle-warnings nnotes seconds)))
(defun one-line-ify (string)
"Return a single-line version of STRING.
Each newline and following whitespace is replaced by a single space."
(loop with count = 0
while (< count (length string))
with new-string = (make-array 0 :element-type 'character :adjustable t
:fill-pointer 0)
when (char= (char string count) #\Newline)
do (loop while (and (< count (length string))
(whitespacep *current-syntax* (char string count)))
do (incf count)
;; Just ignore whitespace if it is last in the
;; string.
finally (when (< count (length string))
(vector-push-extend #\Space new-string)))
else
do (vector-push-extend (char string count) new-string)
(incf count)
finally (return new-string)))
(defgeneric print-for-menu (object stream))
(defun print-note-for-menu (note stream severity ink)
(with-accessors ((message message) (short-message short-message)) note
(with-drawing-options (stream :ink ink
:text-style (make-text-style :sans-serif :italic nil))
(princ severity stream)
(princ " " stream))
(princ (if short-message
(one-line-ify short-message)
(one-line-ify message))
stream)))
(defmacro def-print-for-menu (class name colour)
`(defmethod print-for-menu ((object ,class) stream)
(print-note-for-menu object stream ,name ,colour)))
(def-print-for-menu error-compiler-note "Error" +red+)
(def-print-for-menu read-error-compiler-note "Read Error" +red+)
(def-print-for-menu warning-compiler-note "Warning" +dark-red+)
(def-print-for-menu style-warning-compiler-note "Style Warning" +brown+)
(def-print-for-menu note-compiler-note "Note" +brown+)
(defun show-notes (notes buffer-name definition)
(let ((stream (climacs-gui: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)
(print-for-menu note stream))
(terpri stream)
count note into length
finally (change-space-requirements stream
:height (* length (stream-line-height stream)))
(scroll-extent stream 0 0))))
(defgeneric goto-location (location))
(defmethod goto-location ((location error-location))
(esa:display-message (error-message location)))
[180 lines skipped]
