climacs-cvs

Download

climacs-cvs@common-lisp.net

November 2006

1 participants
11 discussions

[climacs-cvs] CVS climacs
by thenriksen 12 Nov '06

12 Nov '06

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]

1 0