From thenriksen at common-lisp.net Fri Sep 1 18:22:15 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Sep 2006 14:22:15 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060901182215.C9B787434F@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv19572 Modified Files: pane.lisp Log Message: Improved the handling of long lines, the view now automatically scrolls when point is moved beyond the viewport. --- /project/climacs/cvsroot/climacs/pane.lisp 2006/08/31 18:40:48 1.50 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/09/01 18:22:15 1.51 @@ -561,10 +561,8 @@ (defgeneric fix-pane-viewport (pane)) (defmethod fix-pane-viewport ((pane climacs-pane)) - (setf (window-viewport-position pane) (values 0 0)) (change-space-requirements pane :min-width (bounding-rectangle-width (stream-current-output-record pane)))) - (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax basic-syntax) current-p) (display-cache pane) (when (region-visible-p pane) (display-region pane syntax)) @@ -583,7 +581,6 @@ (redisplay-pane-with-syntax pane (syntax (buffer pane)) current-p) (fix-pane-viewport pane)) - (defgeneric full-redisplay (pane)) (defmethod full-redisplay ((pane climacs-pane)) @@ -595,11 +592,25 @@ (let ((point (point pane))) (multiple-value-bind (cursor-x cursor-y line-height) (offset-to-screen-position (offset point) pane) - (updating-output (pane :unique-id -1) + (updating-output (pane :unique-id -1 :cache-value (offset point)) (draw-rectangle* pane (1- cursor-x) cursor-y (+ cursor-x 2) (+ cursor-y line-height) - :ink (if current-p +red+ +blue+)))))) + :ink (if current-p +red+ +blue+)) + ;; Move the position of the viewport if point is outside the + ;; visible area. The trick is that we do this inside the body + ;; of `updating-output', so the view will only be re-focused + ;; when point is actually moved. + (let ((x-position (abs (transform-position (sheet-transformation pane) 0 0))) + (viewport-width (bounding-rectangle-width (or (pane-viewport pane) pane)))) + #+nil(print (list cursor-x (+ x-position (bounding-rectangle-width (pane-viewport pane)))) *terminal-io*) + (cond ((> cursor-x (+ x-position viewport-width)) + (move-sheet pane (round (- (- cursor-x viewport-width))) 0)) + ((> x-position cursor-x) + (move-sheet pane (if (> viewport-width cursor-x) + 0 + (round (- cursor-x))) + 0)))))))) (defgeneric display-region (pane syntax)) From thenriksen at common-lisp.net Sat Sep 2 10:17:52 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 2 Sep 2006 06:17:52 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060902101752.BA5D92201D@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv26232 Modified Files: syntax.lisp misc-commands.lisp core.lisp Log Message: A few small fixes. --- /project/climacs/cvsroot/climacs/syntax.lisp 2006/08/11 21:59:05 1.69 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/09/02 10:17:52 1.70 @@ -772,7 +772,7 @@ '(#\Newline #\Page))) (defgeneric paragraph-delimiter (syntax) - (:documentation "Return the object used as a paragraph + (:documentation "Return the object sequence used as a paragraph deliminter in `syntax'.") (:method (syntax) '(#\Newline #\Newline))) \ No newline at end of file --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/08/20 13:06:39 1.22 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/09/02 10:17:52 1.23 @@ -203,7 +203,8 @@ (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)))) + (downcase-word (point (current-window)) + (syntax (buffer (current-window))))) (set-key 'com-downcase-word 'case-table @@ -217,7 +218,8 @@ 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)))) + (capitalize-word (point (current-window)) + (syntax (buffer (current-window))))) (set-key 'com-capitalize-word 'case-table --- /project/climacs/cvsroot/climacs/core.lisp 2006/08/20 13:06:39 1.5 +++ /project/climacs/cvsroot/climacs/core.lisp 2006/09/02 10:17:52 1.6 @@ -145,14 +145,13 @@ ;;; ;;; Character case -(defun downcase-word (mark &optional (n 1)) +(defun downcase-word (mark syntax &optional (n 1)) "Convert the next N words to lowercase, leaving mark after the last word." - (let ((syntax (syntax (buffer mark)))) - (loop repeat n - do (forward-to-word-boundary mark syntax) - (let ((offset (offset mark))) - (forward-word mark syntax 1 nil) - (downcase-region offset mark))))) + (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." @@ -162,14 +161,13 @@ (forward-word mark syntax 1 nil) (upcase-region offset mark)))) -(defun capitalize-word (mark &optional (n 1)) +(defun capitalize-word (mark syntax &optional (n 1)) "Capitalize the next N words, leaving mark after the last word." - (let ((syntax (syntax (buffer mark)))) - (loop repeat n - do (forward-to-word-boundary mark syntax) - (let ((offset (offset mark))) - (forward-word mark syntax 1 nil) - (capitalize-region offset mark))))) + (loop repeat n + do (forward-to-word-boundary mark syntax) + (let ((offset (offset mark))) + (forward-word mark syntax 1 nil) + (capitalize-region offset mark)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -693,7 +691,7 @@ (error () (progn (beep) (display-message "Invalid answer") (return-from frame-exit nil))))) - do (save-buffer buffer)) + do (save-buffer buffer frame)) (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer))) (buffers frame)) (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?") From thenriksen at common-lisp.net Sat Sep 2 11:41:41 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 2 Sep 2006 07:41:41 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060902114141.00AF0671A3@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv8483 Modified Files: io.lisp Log Message: Oops. Fixed stupid bug that caused Climacs to be unable to load UTF-8 files. --- /project/climacs/cvsroot/climacs/io.lisp 2006/08/20 13:06:39 1.5 +++ /project/climacs/cvsroot/climacs/io.lisp 2006/09/02 11:41:41 1.6 @@ -32,11 +32,10 @@ (let* ((seq (make-string (file-length stream))) (count (#+mcclim read-sequence #-mcclim cl:read-sequence seq stream))) - (if (= count (length seq)) - (insert-buffer-sequence buffer offset - (if (= count (length seq)) - seq - (subseq seq 0 count)))))) + (insert-buffer-sequence buffer offset + (if (= count (length seq)) + seq + (subseq seq 0 count))))) (defmethod make-buffer-from-stream (stream (application-frame climacs)) (let* ((buffer (make-new-buffer application-frame))) From thenriksen at common-lisp.net Sat Sep 2 19:38:30 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 2 Sep 2006 15:38:30 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060902193830.394D72201F@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv1579 Modified Files: lisp-syntax.lisp Log Message: Oops again. Apparently the `package' presentation type was from the McCLIM Listener. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/08/28 17:22:58 1.110 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/02 19:38:29 1.111 @@ -139,7 +139,8 @@ ; as something. (let ((package-name (provided-package-name-at-mark syntax (point pane)))) (if (find-package package-name) - (present (find-package package-name) 'package :stream stream) + (with-output-as-presentation (stream (find-package package-name) 'expression) + (princ package-name stream)) (with-text-face (stream :italic) (princ package-name stream))))) From thenriksen at common-lisp.net Sat Sep 2 21:43:59 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 2 Sep 2006 17:43:59 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060902214359.43487710F4@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv25834 Modified Files: ttcn3-syntax.lisp text-syntax.lisp syntax.lisp slidemacs.lisp prolog-syntax.lisp pane.lisp packages.lisp lisp-syntax.lisp html-syntax.lisp fundamental-syntax.lisp core.lisp cl-syntax.lisp Log Message: Removed the Basic syntax and the `cache' slot in the `climacs-pane' class. Fundamental syntax is now the default. This also required moving some things around, but there has not been any functionality changes. --- /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp 2006/06/12 19:10:58 1.6 +++ /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp 2006/09/02 21:43:56 1.7 @@ -22,7 +22,7 @@ (defpackage :climacs-ttcn3-syntax (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base - :climacs-syntax :flexichain :climacs-pane) + :climacs-syntax :flexichain :climacs-pane :climacs-fundamental-syntax) (:export)) (in-package :climacs-ttcn3-syntax) @@ -119,7 +119,7 @@ (make-instance 'identifier)) (t (fo) (make-instance 'other-entry))))))))) -(define-syntax ttcn3-syntax (basic-syntax) +(define-syntax ttcn3-syntax (fundamental-syntax) ((lexer :reader lexer) (valid-parse :initform 1) (parser)) --- /project/climacs/cvsroot/climacs/text-syntax.lisp 2006/06/12 19:10:58 1.10 +++ /project/climacs/cvsroot/climacs/text-syntax.lisp 2006/09/02 21:43:56 1.11 @@ -65,7 +65,7 @@ (setf low-position (floor (+ low-position 1 high-position) 2))) finally (return low-position))) -(define-syntax text-syntax (basic-syntax) +(define-syntax text-syntax (climacs-fundamental-syntax:fundamental-syntax) ((paragraphs :initform (make-instance 'standard-flexichain)) (sentence-beginnings :initform (make-instance 'standard-flexichain)) (sentence-endings :initform (make-instance 'standard-flexichain))) @@ -79,74 +79,75 @@ (let ((pos1 (index-of-mark-after-offset paragraphs low-offset)) (pos-sentence-beginnings (index-of-mark-after-offset sentence-beginnings low-offset)) (pos-sentence-endings (index-of-mark-after-offset sentence-endings low-offset))) - ;; start by deleting all syntax marks that are between the low and - ;; the high marks - (loop repeat (- (nb-elements paragraphs) pos1) - while (mark<= (element* paragraphs pos1) high-offset) - do (delete* paragraphs pos1)) - (loop repeat (- (nb-elements sentence-beginnings) pos-sentence-beginnings) - while (mark<= (element* sentence-beginnings pos-sentence-beginnings) high-offset) - do (delete* sentence-beginnings pos-sentence-beginnings)) - (loop repeat (- (nb-elements sentence-endings) pos-sentence-endings) - while (mark<= (element* sentence-endings pos-sentence-endings) high-offset) - do (delete* sentence-endings pos-sentence-endings)) - - ;; check the zone between low-offset and high-offset for - ;; paragraph delimiters and sentence delimiters - (loop with buffer-size = (size buffer) - for offset from low-offset to high-offset ;; Could be rewritten with even fewer buffer-object calls, - for current-object = nil then (if (>= offset high-offset) nil (buffer-object buffer offset)) ;; but it'd be premature optimization, and messy besides. - for next-object = nil then (if (>= offset (- high-offset 1)) nil (buffer-object buffer (1+ offset))) - for prev-object = nil then (if (= offset low-offset) nil (buffer-object buffer (1- offset))) - for before-prev-object = nil then (if (<= offset (1+ low-offset)) nil (buffer-object buffer (- offset 2))) - do (progn - (cond ((and (< offset buffer-size) - (member prev-object '(#\. #\? #\!)) - (or (= offset (1- buffer-size)) - (and (member current-object '(#\Newline #\Space #\Tab)) - (or (= offset 1) - (not (member before-prev-object '(#\Newline #\Space #\Tab))))))) - (let ((m (clone-mark (low-mark buffer) :left))) - (setf (offset m) offset) - (insert* sentence-endings pos-sentence-endings m)) - (incf pos-sentence-endings)) - - ((and (>= offset 0) - (not (member current-object '(#\. #\? #\! #\Newline #\Space #\Tab))) - (or (= offset 0) - (member prev-object '(#\Newline #\Space #\Tab))) - (or (<= offset 1) - (member before-prev-object '(#\. #\? #\! #\Newline #\Space #\Tab)))) - (let ((m (clone-mark (low-mark buffer) :right))) - (setf (offset m) offset) - (insert* sentence-beginnings pos-sentence-beginnings m)) - (incf pos-sentence-beginnings)) - (t nil)) - - ;; Paragraphs - - (cond ((and (< offset buffer-size) ;; Ends - (not (eql current-object #\Newline)) - (or (zerop offset) - (and (eql prev-object #\Newline) - (or (= offset 1) - (eql before-prev-object #\Newline))))) - (let ((m (clone-mark (low-mark buffer) :left))) - (setf (offset m) offset) - (insert* paragraphs pos1 m)) - (incf pos1)) - - ((and (plusp offset) ;;Beginnings - (not (eql prev-object #\Newline)) - (or (= offset buffer-size) - (and (eql current-object #\Newline) - (or (= offset (1- buffer-size)) - (eql next-object #\Newline))))) - (let ((m (clone-mark (low-mark buffer) :right))) - (setf (offset m) offset) - (insert* paragraphs pos1 m)) - (incf pos1)) - (t nil)))))))) + ;; start by deleting all syntax marks that are between the low and + ;; the high marks + (loop repeat (- (nb-elements paragraphs) pos1) + while (mark<= (element* paragraphs pos1) high-offset) + do (delete* paragraphs pos1)) + (loop repeat (- (nb-elements sentence-beginnings) pos-sentence-beginnings) + while (mark<= (element* sentence-beginnings pos-sentence-beginnings) high-offset) + do (delete* sentence-beginnings pos-sentence-beginnings)) + (loop repeat (- (nb-elements sentence-endings) pos-sentence-endings) + while (mark<= (element* sentence-endings pos-sentence-endings) high-offset) + do (delete* sentence-endings pos-sentence-endings)) + + ;; check the zone between low-offset and high-offset for + ;; paragraph delimiters and sentence delimiters + (loop with buffer-size = (size buffer) + for offset from low-offset to high-offset ;; Could be rewritten with even fewer buffer-object calls, + for current-object = nil then (if (>= offset high-offset) nil (buffer-object buffer offset)) ;; but it'd be premature optimization, and messy besides. + for next-object = nil then (if (>= offset (- high-offset 1)) nil (buffer-object buffer (1+ offset))) + for prev-object = nil then (if (= offset low-offset) nil (buffer-object buffer (1- offset))) + for before-prev-object = nil then (if (<= offset (1+ low-offset)) nil (buffer-object buffer (- offset 2))) + do (progn + (cond ((and (< offset buffer-size) + (member prev-object '(#\. #\? #\!)) + (or (= offset (1- buffer-size)) + (and (member current-object '(#\Newline #\Space #\Tab)) + (or (= offset 1) + (not (member before-prev-object '(#\Newline #\Space #\Tab))))))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) offset) + (insert* sentence-endings pos-sentence-endings m)) + (incf pos-sentence-endings)) + + ((and (>= offset 0) + (not (member current-object '(#\. #\? #\! #\Newline #\Space #\Tab))) + (or (= offset 0) + (member prev-object '(#\Newline #\Space #\Tab))) + (or (<= offset 1) + (member before-prev-object '(#\. #\? #\! #\Newline #\Space #\Tab)))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) offset) + (insert* sentence-beginnings pos-sentence-beginnings m)) + (incf pos-sentence-beginnings)) + (t nil)) + + ;; Paragraphs + + (cond ((and (< offset buffer-size) ;; Ends + (not (eql current-object #\Newline)) + (or (zerop offset) + (and (eql prev-object #\Newline) + (or (= offset 1) + (eql before-prev-object #\Newline))))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) offset) + (insert* paragraphs pos1 m)) + (incf pos1)) + + ((and (plusp offset) ;;Beginnings + (not (eql prev-object #\Newline)) + (or (= offset buffer-size) + (and (eql current-object #\Newline) + (or (= offset (1- buffer-size)) + (eql next-object #\Newline))))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) offset) + (insert* paragraphs pos1 m)) + (incf pos1)) + (t nil))))))) + (call-next-method)) (defmethod backward-one-paragraph (mark (syntax text-syntax)) (with-slots (paragraphs) syntax --- /project/climacs/cvsroot/climacs/syntax.lisp 2006/09/02 10:17:52 1.70 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/09/02 21:43:56 1.71 @@ -112,11 +112,15 @@ (defgeneric name-for-info-pane (syntax &key &allow-other-keys) (:documentation "Return the name that should be used for the - info-pane for panes displaying a buffer in this syntax.")) + info-pane for panes displaying a buffer in this syntax.") + (:method (syntax &key &allow-other-keys) + (name syntax))) (defgeneric display-syntax-name (syntax stream &key &allow-other-keys) (:documentation "Draw the name of the syntax `syntax' to - `stream'. This is meant to be called for the info-pane.")) + `stream'. This is meant to be called for the info-pane.") + (:method (syntax stream &rest args &key) + (princ (apply #'name-for-info-pane syntax args) stream))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -124,6 +128,12 @@ (defparameter *syntaxes* '()) +(defvar *default-syntax* nil + "The name of the default syntax. Must be a symbol. + +This syntax will be used by default, when no other syntax is +mandated by file types or attribute lists.") + (defstruct (syntax-description (:type list)) (name (error "required argument") :type string) (class-name (error "required argument") :type symbol) @@ -251,37 +261,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Basic syntax - -;;; FIXME: this is a really bad name. It's even worse if it's -;;; case-insensitive. Emacs' "Fundamental" isn't too bad. -(define-syntax basic-syntax (syntax) - () - (:name "Basic")) - -(defmethod update-syntax (buffer (syntax basic-syntax)) - (declare (ignore buffer)) - nil) - -(defmethod update-syntax-for-display (buffer (syntax basic-syntax) from to) - (declare (ignore buffer from to)) - nil) - -(defmethod name-for-info-pane ((syntax basic-syntax) &key) - (name syntax)) - -(defmethod display-syntax-name ((syntax basic-syntax) stream &rest args &key) - (princ (apply #'name-for-info-pane syntax args) stream)) - -(defmethod syntax-line-indentation (mark tab-width (syntax basic-syntax)) - (declare (ignore mark tab-width)) - 0) - -(defmethod eval-defun (mark syntax) - (error 'no-such-operation)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; Incremental Earley parser ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; --- /project/climacs/cvsroot/climacs/slidemacs.lisp 2006/06/12 19:10:58 1.10 +++ /project/climacs/cvsroot/climacs/slidemacs.lisp 2006/09/02 21:43:56 1.11 @@ -22,7 +22,7 @@ (defpackage :climacs-slidemacs-editor (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base - :climacs-syntax :flexichain :climacs-pane) + :climacs-syntax :flexichain :climacs-pane :climacs-fundamental-syntax) (:export)) (in-package :climacs-slidemacs-editor) @@ -105,7 +105,7 @@ (make-instance 'slidemacs-keyword)) (t (fo) (make-instance 'other-entry))))))))) -(define-syntax slidemacs-editor-syntax (basic-syntax) +(define-syntax slidemacs-editor-syntax (fundamental-syntax) ((lexer :reader lexer) (valid-parse :initform 1) (parser)) (:name "Slidemacs-Editor") --- /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2006/06/12 19:10:58 1.28 +++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2006/09/02 21:43:56 1.29 @@ -26,7 +26,7 @@ (defclass prolog-parse-tree (parse-tree) ()) -(define-syntax prolog-syntax (basic-syntax) +(define-syntax prolog-syntax (fundamental-syntax) ((lexer :reader lexer) (valid-parse :initform 1) (parser) --- /project/climacs/cvsroot/climacs/pane.lisp 2006/09/01 18:22:15 1.51 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/09/02 21:43:56 1.52 @@ -260,7 +260,7 @@ (declare (ignore args)) (with-slots (syntax point) buffer (setf syntax (make-instance - 'basic-syntax :buffer (implementation buffer)) + *default-syntax* :buffer (implementation buffer)) point (clone-mark (low-mark buffer) :right)))) (defmethod (setf syntax) :after (syntax (buffer climacs-buffer)) @@ -286,22 +286,10 @@ (query-replace-mode :initform nil :accessor query-replace-mode) (query-replace-state :initform nil :accessor query-replace-state) (region-visible-p :initform nil :accessor region-visible-p) - (full-redisplay-p :initform nil :accessor full-redisplay-p) - (cache :initform (let ((cache (make-instance 'standard-flexichain))) - (insert* cache 0 nil) - cache))) + (full-redisplay-p :initform nil :accessor full-redisplay-p)) (:default-initargs :default-view +climacs-textual-view+)) -(defgeneric clear-cache (pane) - (:documentation "Clear the cache for `pane.'")) - -(defmethod clear-cache ((pane climacs-pane)) - (with-slots (cache) pane - (setf cache (let ((cache (make-instance 'standard-flexichain))) - (insert* cache 0 nil) - cache)))) - (defmethod tab-width ((pane climacs-pane)) (tab-width (stream-default-view pane))) @@ -343,95 +331,10 @@ top (clone-mark (low-mark buffer) :left) bot (clone-mark (high-mark buffer) :right)))) +;; FIXME: Move this somewhere else. (define-presentation-type url () :inherit-from 'string) -(defgeneric present-contents (contents pane)) - -(defmethod present-contents (contents pane) - (unless (null contents) - (present contents - (if (and (>= (length contents) 7) (string= (subseq contents 0 7) "http://")) - 'url - 'string) - :stream pane))) - -(defgeneric display-line (pane line offset syntax view)) - -(defmethod display-line (pane line offset (syntax basic-syntax) (view textual-view)) - (declare (ignore offset)) - (let ((saved-index nil) - (id 0)) - (flet ((output-word (index) - (unless (null saved-index) - (let ((contents (coerce (subseq line saved-index index) 'string))) - (updating-output (pane :unique-id (incf id) - :id-test #'= - :cache-value contents - :cache-test #'equal) - (present-contents contents pane))) - (setf saved-index nil)))) - (with-slots (bot scan cursor-x cursor-y) pane - (loop with space-width = (space-width pane) - with tab-width = (tab-width pane) - for index from 0 - for obj across line - when (mark= scan (point pane)) - do (multiple-value-bind (x y) (stream-cursor-position pane) - (setf cursor-x (+ x (if (null saved-index) - 0 - (* space-width (- index saved-index)))) - cursor-y y)) - do (cond ((eql obj #\Space) - (output-word index) - (stream-increment-cursor-position pane space-width 0)) - ((eql obj #\Tab) - (output-word index) - (let ((x (stream-cursor-position pane))) - (stream-increment-cursor-position - pane (- tab-width (mod x tab-width)) 0))) - ((constituentp obj) - (when (null saved-index) - (setf saved-index index))) - ((characterp obj) - (output-word index) - (updating-output (pane :unique-id (incf id) - :id-test #'= - :cache-value obj - :cache-test #'equal) - (present obj 'character :stream pane))) - (t - (output-word index) - (updating-output (pane :unique-id (incf id) - :id-test #'= - :cache-value obj - :cache-test #'equal) - (present obj 'character :stream pane)))) - (incf scan) - finally (output-word index) - (when (mark= scan (point pane)) - (multiple-value-bind (x y) (stream-cursor-position pane) - (setf cursor-x x - cursor-y y))) - (terpri pane) - (incf scan)))))) - -(defgeneric fill-cache (pane) - (:documentation "fill nil cache entries from the buffer")) - -(defmethod fill-cache (pane) - (with-slots (top bot cache) pane - (let ((mark1 (clone-mark top)) - (mark2 (clone-mark top))) - (loop for line from 0 below (nb-elements cache) - do (beginning-of-line mark1) - (end-of-line mark2) - when (null (element* cache line)) - do (setf (element* cache line) (region-to-sequence mark1 mark2)) - unless (end-of-buffer-p mark2) - do (setf (offset mark1) (1+ (offset mark2)) - (offset mark2) (offset mark1)))))) - (defun nb-lines-in-pane (pane) (let* ((medium (sheet-medium pane)) (style (medium-text-style medium)) @@ -441,91 +344,53 @@ (max 1 (floor h (+ height (stream-vertical-spacing pane))))))) ;;; make the region on display fit the size of the pane as closely as -;;; possible by adjusting bot leaving top intact. Also make the cache -;;; size fit the size of the region on display. -(defun adjust-cache-size-and-bot (pane) +;;; possible by adjusting bot leaving top intact. +(defun adjust-pane-bot (pane) (let ((nb-lines-in-pane (nb-lines-in-pane pane))) - (with-slots (top bot cache) pane + (with-slots (top bot) pane (setf (offset bot) (offset top)) (end-of-line bot) (loop until (end-of-buffer-p bot) repeat (1- nb-lines-in-pane) do (forward-object bot) - (end-of-line bot)) - (let ((nb-lines-on-display (1+ (number-of-lines-in-region top bot)))) - (loop repeat (- (nb-elements cache) nb-lines-on-display) - do (pop-end cache)) - (loop repeat (- nb-lines-on-display (nb-elements cache)) - do (push-end cache nil)))))) - -;;; put all-nil entries in the cache -(defun empty-cache (cache) - (loop for i from 0 below (nb-elements cache) - do (setf (element* cache i) nil))) - -;;; empty the cache and try to put point close to the middle -;;; of the pane by moving top half a pane-size up. -(defun reposition-window (pane) + (end-of-line bot))))) + +;;; Try to put point close to the middle of the pane by moving top +;;; half a pane-size up. +(defun reposition-pane (pane) (let ((nb-lines-in-pane (nb-lines-in-pane pane))) - (with-slots (top cache) pane - (empty-cache cache) - (setf (offset top) (offset (point pane))) - (loop do (beginning-of-line top) - repeat (floor nb-lines-in-pane 2) - until (beginning-of-buffer-p top) - do (decf (offset top)) - (beginning-of-line top))))) - -;;; Make the cache reflect the contents of the buffer starting at top, -;;; trying to preserve contents as much as possible, and inserting a -;;; nil entry where buffer contents is unknonwn. The size of the -;;; cache at the end may be smaller than, equal to, or greater than -;;; the number of lines in the pane. -(defun adjust-cache (pane) + (with-slots (top) pane + (setf (offset top) (offset (point pane))) + (loop do (beginning-of-line top) + repeat (floor nb-lines-in-pane 2) + until (beginning-of-buffer-p top) + do (decf (offset top)) + (beginning-of-line top))))) + +;; Adjust the bottom and top marks of the pane to be correct, and +;; reposition the pane if point is outside the visible area. +(defun adjust-pane (pane) (let* ((buffer (buffer pane)) - (high-mark (high-mark buffer)) (low-mark (low-mark buffer)) (nb-lines-in-pane (nb-lines-in-pane pane))) - (with-slots (top bot cache) pane - (beginning-of-line top) - (end-of-line bot) - (if (or (mark< (point pane) top) - (>= (number-of-lines-in-region top (point pane)) nb-lines-in-pane) - (and (mark< low-mark top) - (>= (number-of-lines-in-region top high-mark) (nb-elements cache)))) - (reposition-window pane) - (when (mark>= high-mark low-mark) - (let* ((n1 (number-of-lines-in-region top low-mark)) - (n2 (1+ (number-of-lines-in-region low-mark high-mark))) - (n3 (number-of-lines-in-region high-mark bot)) - (diff (- (+ n1 n2 n3) (nb-elements cache)))) - (cond ((>= (+ n1 n2 n3) (+ (nb-elements cache) 20)) - (setf (offset bot) (offset top)) - (end-of-line bot) - (loop for i from n1 below (nb-elements cache) - do (setf (element* cache i) nil))) - ((>= diff 0) - (loop repeat diff do (insert* cache n1 nil)) - (loop for i from (+ n1 diff) below (+ n1 n2) - do (setf (element* cache i) nil))) - (t - (loop repeat (- diff) do (delete* cache n1)) - (loop for i from n1 below (+ n1 n2) - do (setf (element* cache i) nil))))))))) - (adjust-cache-size-and-bot pane)) + (with-slots (top bot) pane + (beginning-of-line top) + (end-of-line bot) + (when (or (mark< (point pane) top) + (>= (number-of-lines-in-region top (point pane)) nb-lines-in-pane) + (mark< low-mark top)) + (reposition-pane pane)))) + (adjust-pane-bot pane)) (defun page-down (pane) - (adjust-cache pane) - (with-slots (top bot cache) pane + (with-slots (top bot) pane (when (mark> (size (buffer bot)) bot) - (empty-cache cache) (setf (offset top) (offset bot)) (beginning-of-line top) (setf (offset (point pane)) (offset top))))) (defun page-up (pane) - (adjust-cache pane) - (with-slots (top bot cache) pane + (with-slots (top bot) pane (when (> (offset top) 0) (let ((nb-lines-in-region (number-of-lines-in-region top bot))) (setf (offset bot) (offset top)) @@ -535,48 +400,25 @@ do (decf (offset top)) (beginning-of-line top)) (setf (offset (point pane)) (offset top)) - (adjust-cache pane) (setf (offset (point pane)) (offset bot)) - (beginning-of-line (point pane)) - (empty-cache cache))))) - -(defun display-cache (pane) - (with-slots (top bot scan cache cursor-x cursor-y) pane - (loop with start-offset = (offset top) - for id from 0 below (nb-elements cache) - do (setf scan start-offset) - (updating-output - (pane :unique-id id - :id-test #'equal - :cache-value (element* cache id) - :cache-test #'equal) - (display-line pane (element* cache id) start-offset - (syntax (buffer pane)) (stream-default-view pane))) - (incf start-offset (1+ (length (element* cache id))))) - (when (mark= scan (point pane)) - (multiple-value-bind (x y) (stream-cursor-position pane) - (setf cursor-x x - cursor-y y))))) + (beginning-of-line (point pane)))))) (defgeneric fix-pane-viewport (pane)) (defmethod fix-pane-viewport ((pane climacs-pane)) - (change-space-requirements pane :min-width (bounding-rectangle-width (stream-current-output-record pane)))) - -(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax basic-syntax) current-p) - (display-cache pane) - (when (region-visible-p pane) (display-region pane syntax)) - (display-cursor pane syntax current-p)) + (change-space-requirements + pane + :min-width (bounding-rectangle-width (stream-current-output-record pane)) + :max-height (bounding-rectangle-width (or (pane-viewport pane) pane)))) (defgeneric redisplay-pane (pane current-p)) (defmethod redisplay-pane ((pane climacs-pane) current-p) (if (full-redisplay-p pane) - (progn (reposition-window pane) - (adjust-cache-size-and-bot pane) + (progn (reposition-pane pane) + (adjust-pane-bot pane) (setf (full-redisplay-p pane) nil)) - (adjust-cache pane)) - (fill-cache pane) + (adjust-pane pane)) (update-syntax-for-display (buffer pane) (syntax (buffer pane)) (top pane) (bot pane)) (redisplay-pane-with-syntax pane (syntax (buffer pane)) current-p) (fix-pane-viewport pane)) @@ -588,165 +430,8 @@ (defgeneric display-cursor (pane syntax current-p)) -(defmethod display-cursor ((pane climacs-pane) (syntax basic-syntax) current-p) - (let ((point (point pane))) - (multiple-value-bind (cursor-x cursor-y line-height) - (offset-to-screen-position (offset point) pane) - (updating-output (pane :unique-id -1 :cache-value (offset point)) - (draw-rectangle* pane - (1- cursor-x) cursor-y - (+ cursor-x 2) (+ cursor-y line-height) - :ink (if current-p +red+ +blue+)) - ;; Move the position of the viewport if point is outside the - ;; visible area. The trick is that we do this inside the body - ;; of `updating-output', so the view will only be re-focused - ;; when point is actually moved. - (let ((x-position (abs (transform-position (sheet-transformation pane) 0 0))) - (viewport-width (bounding-rectangle-width (or (pane-viewport pane) pane)))) - #+nil(print (list cursor-x (+ x-position (bounding-rectangle-width (pane-viewport pane)))) *terminal-io*) - (cond ((> cursor-x (+ x-position viewport-width)) - (move-sheet pane (round (- (- cursor-x viewport-width))) 0)) - ((> x-position cursor-x) - (move-sheet pane (if (> viewport-width cursor-x) - 0 - (round (- cursor-x))) - 0)))))))) - (defgeneric display-region (pane syntax)) -(defmethod display-region ((pane climacs-pane) (syntax basic-syntax)) - (highlight-region pane (point pane) (mark pane))) - -(defgeneric highlight-region (pane mark1 offset2 &optional ink)) - -(defmethod highlight-region ((pane climacs-pane) (offset1 integer) (offset2 integer) - &optional (ink (compose-in +green+ (make-opacity .1)))) - ;; FIXME stream-vertical-spacing between lines - ;; FIXME note sure updating output is working properly... - ;; we'll call offset1 CURSOR and offset2 MARK - (multiple-value-bind (cursor-x cursor-y line-height) - (offset-to-screen-position offset1 pane) - (multiple-value-bind (mark-x mark-y) - (offset-to-screen-position offset2 pane) - (cond - ;; mark and point are above the screen - ((and (null cursor-y) (null mark-y) - (null cursor-x) (null mark-x)) - nil) - ;; mark and point are below the screen - ((and (null cursor-y) (null mark-y) - cursor-x mark-x) - nil) - ;; mark or point is above the screen, and point or mark below it - ((and (null cursor-y) (null mark-y) - (or (and cursor-x (null mark-x)) - (and (null cursor-x) mark-x))) - (let ((width (stream-text-margin pane)) - (height (bounding-rectangle-height - (window-viewport pane)))) - (updating-output (pane :unique-id -3 - :cache-value (list cursor-y mark-y cursor-x mark-x - height width ink)) - (draw-rectangle* pane - 0 0 - width height - :ink ink)))) - ;; mark is above the top of the screen - ((and (null mark-y) (null mark-x)) - (let ((width (stream-text-margin pane))) - (updating-output (pane :unique-id -3 - :cache-value ink) - (updating-output (pane :cache-value (list mark-y mark-x cursor-y width)) - (draw-rectangle* pane - 0 0 - width cursor-y - :ink ink)) - (updating-output (pane :cache-value (list cursor-y cursor-x)) - (draw-rectangle* pane - 0 cursor-y - cursor-x (+ cursor-y line-height) - :ink ink))))) - ;; mark is below the bottom of the screen - ((and (null mark-y) mark-x) - (let ((width (stream-text-margin pane)) - (height (bounding-rectangle-height - (window-viewport pane)))) - (updating-output (pane :unique-id -3 - :cache-value ink) - (updating-output (pane :cache-value (list cursor-y width height)) [76 lines skipped] --- /project/climacs/cvsroot/climacs/packages.lisp 2006/08/20 13:06:38 1.112 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/02 21:43:56 1.113 @@ -118,13 +118,12 @@ (defpackage :climacs-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) - (:export #:syntax #:define-syntax + (:export #:syntax #:define-syntax #:*default-syntax* #:eval-option #:define-option-for-syntax #:current-attributes-for-syntax #:make-attribute-line #:syntax-from-name - #:basic-syntax #:update-syntax #:update-syntax-for-display #:grammar #:grammar-rule #:add-rule #:parser #:initial-state @@ -179,6 +178,7 @@ #: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 @@ -311,6 +311,11 @@ 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 @@ -367,7 +372,7 @@ )) (defpackage :climacs-core - (:use :clim-lisp :climacs-base :climacs-buffer + (: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) (:export #:display-string @@ -432,28 +437,23 @@ command definitions, as well as some useful automatic command-defining facilities.")) -(defpackage :climacs-fundamental-syntax - (:use :clim-lisp :clim :climacs-buffer :climacs-base - :climacs-syntax :flexichain :climacs-pane) - (:export #:fundamental-syntax)) - (defpackage :climacs-html-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base - :climacs-syntax :flexichain :climacs-pane)) + :climacs-syntax :flexichain :climacs-pane :climacs-fundamental-syntax)) (defpackage :climacs-prolog-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base - :climacs-syntax :flexichain :climacs-pane :climacs-core) + :climacs-syntax :flexichain :climacs-pane :climacs-core :climacs-fundamental-syntax) (:shadow #:atom #:close #:exp #:integer #:open #:variable)) (defpackage :climacs-cl-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base - :climacs-syntax :flexichain :climacs-pane) + :climacs-syntax :flexichain :climacs-pane :climacs-fundamental-syntax) (:export)) (defpackage :climacs-lisp-syntax (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base - :climacs-syntax :flexichain :climacs-pane :climacs-gui + :climacs-syntax :climacs-fundamental-syntax :flexichain :climacs-pane :climacs-gui :climacs-motion :climacs-editing :climacs-core) (:export #:lisp-string #:edit-definition)) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/02 19:38:29 1.111 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/02 21:43:56 1.112 @@ -60,7 +60,7 @@ ;;; ;;; the syntax object -(define-syntax lisp-syntax (basic-syntax) +(define-syntax lisp-syntax (fundamental-syntax) ((stack-top :initform nil) (potentially-valid-trees) (lookahead-lexeme :initform nil :accessor lookahead-lexeme) --- /project/climacs/cvsroot/climacs/html-syntax.lisp 2006/06/12 19:10:58 1.34 +++ /project/climacs/cvsroot/climacs/html-syntax.lisp 2006/09/02 21:43:56 1.35 @@ -22,7 +22,7 @@ (in-package :climacs-html-syntax) -(define-syntax html-syntax (basic-syntax) +(define-syntax html-syntax (fundamental-syntax) ((lexer :reader lexer) (valid-parse :initform 1) (parser)) --- /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/06/12 19:10:58 1.4 +++ /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/09/02 21:43:56 1.5 @@ -26,9 +26,9 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; the syntax object +;;; The syntax object and misc stuff. -(define-syntax fundamental-syntax (basic-syntax) +(define-syntax fundamental-syntax (syntax) ((lines :initform (make-instance 'standard-flexichain)) (scan)) (:name "Fundamental")) @@ -38,6 +38,8 @@ (with-slots (buffer scan) syntax (setf scan (clone-mark (low-mark buffer) :left)))) +(setf *default-syntax* 'fundamental-syntax) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; update syntax @@ -120,74 +122,231 @@ 'string))) (updating-output (pane :unique-id (incf id) :cache-value contents - :cache-test #'string=) + :cache-test #'eql) (unless (null contents) (present contents 'string :stream pane)))) (setf saved-offset nil)))) (with-slots (bot scan cursor-x cursor-y) pane - (loop with space-width = (space-width pane) - with tab-width = (tab-width pane) - until (end-of-line-p mark) - do (let ((obj (object-after mark))) - (cond ((eql obj #\Space) - (output-word) - (stream-increment-cursor-position pane space-width 0)) - ((eql obj #\Tab) - (output-word) - (let ((x (stream-cursor-position pane))) - (stream-increment-cursor-position - pane (- tab-width (mod x tab-width)) 0))) - ((constituentp obj) - (when (null saved-offset) - (setf saved-offset (offset mark)))) - ((characterp obj) - (output-word) - (updating-output (pane :unique-id (incf id) - :cache-value obj) - (present obj 'character :stream pane))) - (t - (output-word) - (updating-output (pane :unique-id (incf id) - :cache-value obj - :cache-test #'eq) - (present obj 'character :stream pane))))) - do (forward-object mark) - finally (output-word) - (terpri pane)))))) + (loop with space-width = (space-width pane) + with tab-width = (tab-width pane) + until (end-of-line-p mark) + do (let ((obj (object-after mark))) + (cond ((eql obj #\Space) + (output-word) + (stream-increment-cursor-position pane space-width 0)) + ((eql obj #\Tab) + (output-word) + (let ((x (stream-cursor-position pane))) + (stream-increment-cursor-position + pane (- tab-width (mod x tab-width)) 0))) + ((constituentp obj) + (when (null saved-offset) + (setf saved-offset (offset mark)))) + ((characterp obj) + (output-word) + (updating-output (pane :unique-id (incf id) + :cache-value obj) + (present obj 'character :stream pane))) + (t + (output-word) + (updating-output (pane :unique-id (incf id) + :cache-value obj + :cache-test #'eq) + (present obj 'character :stream pane))))) + do (forward-object mark) + finally + (output-word) + (terpri)))))) (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax fundamental-syntax) current-p) (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)) - (setf *white-space-start* (offset top)) - (with-slots (lines) syntax - (with-slots (lines scan) syntax - (let ((low-index 0) - (high-index (nb-elements lines))) - (loop while (< low-index high-index) - do (let* ((middle (floor (+ low-index high-index) 2)) - (line-start (start-mark (element* lines middle)))) - (cond ((mark> top line-start) - (setf low-index (1+ middle))) - ((mark< top line-start) - (setf high-index middle)) - (t - (setf low-index middle - high-index middle))))) - (loop for i from low-index - while (and (< i (nb-elements lines)) - (mark< (start-mark (element* lines i)) - bot)) - do (let ((line (element* lines i))) - (updating-output (pane :unique-id line - :id-test #'eq - :cache-value line - :cache-test #'eq) - (display-line pane (start-mark (element* lines i)))))))))) + (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot))) + *current-line* 0 + (aref *cursor-positions* 0) (stream-cursor-position pane)) + (setf *white-space-start* (offset top)) + (with-slots (lines scan) syntax + (let ((low-index 0) + (high-index (nb-elements lines))) + (loop while (< low-index high-index) + do (let* ((middle (floor (+ low-index high-index) 2)) + (line-start (start-mark (element* lines middle)))) + (cond ((mark> top line-start) + (setf low-index (1+ middle))) + ((mark< top line-start) + (setf high-index middle)) + (t + (setf low-index middle + high-index middle))))) + (loop for i from low-index + while (and (< i (nb-elements lines)) + (mark< (start-mark (element* lines i)) + bot)) + do (let ((line (element* lines i))) + (updating-output (pane :unique-id i + :id-test #'eql + :cache-value line + :cache-test #'equal) + (display-line pane (start-mark (element* lines i))))))))) (when (region-visible-p pane) (display-region pane syntax)) (display-cursor pane syntax current-p)) +(defmethod display-cursor ((pane climacs-pane) (syntax fundamental-syntax) current-p) + (let ((point (point pane))) + (multiple-value-bind (cursor-x cursor-y line-height) + (offset-to-screen-position (offset point) pane) + (updating-output (pane :unique-id -1 :cache-value (offset point)) + (draw-rectangle* pane + (1- cursor-x) cursor-y + (+ cursor-x 2) (+ cursor-y line-height) + :ink (if current-p +red+ +blue+)) + ;; Move the position of the viewport if point is outside the + ;; visible area. The trick is that we do this inside the body + ;; of `updating-output', so the view will only be re-focused + ;; when point is actually moved. + (let ((x-position (abs (transform-position (sheet-transformation pane) 0 0))) + (viewport-width (bounding-rectangle-width (or (pane-viewport pane) pane)))) + #+nil(print (list cursor-x (+ x-position (bounding-rectangle-width (pane-viewport pane)))) *terminal-io*) + (cond ((> cursor-x (+ x-position viewport-width)) + (move-sheet pane (round (- (- cursor-x viewport-width))) 0)) + ((> x-position cursor-x) + (move-sheet pane (if (> viewport-width cursor-x) + 0 + (round (- cursor-x))) + 0)))))))) + +(defmethod display-region ((pane climacs-pane) (syntax fundamental-syntax)) + (highlight-region pane (point pane) (mark pane))) + +(defgeneric highlight-region (pane mark1 offset2 &optional ink)) + +(defmethod highlight-region ((pane climacs-pane) (offset1 integer) (offset2 integer) + &optional (ink (compose-in +green+ (make-opacity .1)))) + ;; FIXME stream-vertical-spacing between lines + ;; FIXME note sure updating output is working properly... + ;; we'll call offset1 CURSOR and offset2 MARK + (multiple-value-bind (cursor-x cursor-y line-height) + (offset-to-screen-position offset1 pane) + (multiple-value-bind (mark-x mark-y) + (offset-to-screen-position offset2 pane) + (cond + ;; mark and point are above the screen + ((and (null cursor-y) (null mark-y) + (null cursor-x) (null mark-x)) + nil) + ;; mark and point are below the screen + ((and (null cursor-y) (null mark-y) + cursor-x mark-x) + nil) + ;; mark or point is above the screen, and point or mark below it + ((and (null cursor-y) (null mark-y) + (or (and cursor-x (null mark-x)) + (and (null cursor-x) mark-x))) + (let ((width (stream-text-margin pane)) + (height (bounding-rectangle-height + (window-viewport pane)))) + (updating-output (pane :unique-id -3 + :cache-value (list cursor-y mark-y cursor-x mark-x + height width ink)) + (draw-rectangle* pane + 0 0 + width height + :ink ink)))) + ;; mark is above the top of the screen + ((and (null mark-y) (null mark-x)) + (let ((width (stream-text-margin pane))) + (updating-output (pane :unique-id -3 + :cache-value ink) + (updating-output (pane :cache-value (list mark-y mark-x cursor-y width)) + (draw-rectangle* pane + 0 0 + width cursor-y + :ink ink)) + (updating-output (pane :cache-value (list cursor-y cursor-x)) + (draw-rectangle* pane + 0 cursor-y + cursor-x (+ cursor-y line-height) + :ink ink))))) + ;; mark is below the bottom of the screen + ((and (null mark-y) mark-x) + (let ((width (stream-text-margin pane)) + (height (bounding-rectangle-height + (window-viewport pane)))) + (updating-output (pane :unique-id -3 + :cache-value ink) + (updating-output (pane :cache-value (list cursor-y width height)) + (draw-rectangle* pane + 0 (+ cursor-y line-height) + width height + :ink ink)) + (updating-output (pane :cache-value (list cursor-x cursor-y width)) + (draw-rectangle* pane + cursor-x cursor-y + width (+ cursor-y line-height) + :ink ink))))) + ;; mark is at point + ((and (= mark-x cursor-x) (= mark-y cursor-y)) + nil) + ;; mark and point are on the same line + ((= mark-y cursor-y) + (updating-output (pane :unique-id -3 + :cache-value (list offset1 offset2 ink)) + (draw-rectangle* pane + mark-x mark-y + cursor-x (+ cursor-y line-height) + :ink ink))) + ;; mark and point are both visible, mark above point + ((< mark-y cursor-y) + (let ((width (stream-text-margin pane))) + (updating-output (pane :unique-id -3 + :cache-value ink) + (updating-output (pane :cache-value (list mark-x mark-y width)) + (draw-rectangle* pane + mark-x mark-y + width (+ mark-y line-height) + :ink ink)) + (updating-output (pane :cache-value (list cursor-x cursor-y)) + (draw-rectangle* pane + 0 cursor-y + cursor-x (+ cursor-y line-height) + :ink ink)) + (updating-output (pane :cache-value (list mark-y cursor-y width)) + (draw-rectangle* pane + 0 (+ mark-y line-height) + width cursor-y + :ink ink))))) + ;; mark and point are both visible, point above mark + (t + (let ((width (stream-text-margin pane))) + (updating-output (pane :unique-id -3 + :cache-value ink) + (updating-output (pane :cache-value (list cursor-x cursor-y width)) + (draw-rectangle* pane + cursor-x cursor-y + width (+ cursor-y line-height) + :ink ink)) + (updating-output (pane :cache-value (list mark-x mark-y)) + (draw-rectangle* pane + 0 mark-y + mark-x (+ mark-y line-height) + :ink ink)) + (updating-output (pane :cache-value (list cursor-y mark-y width)) + (draw-rectangle* pane + 0 (+ cursor-y line-height) + width mark-y + :ink ink))))))))) + +(defmethod highlight-region ((pane climacs-pane) (mark1 mark) (mark2 mark) + &optional (ink (compose-in +green+ (make-opacity .1)))) + (highlight-region pane (offset mark1) (offset mark2) ink)) + +(defmethod highlight-region ((pane climacs-pane) (mark1 mark) (offset2 integer) + &optional (ink (compose-in +green+ (make-opacity .1)))) + (highlight-region pane (offset mark1) offset2 ink)) + +(defmethod highlight-region ((pane climacs-pane) (offset1 integer) (mark2 mark) + &optional (ink (compose-in +green+ (make-opacity .1)))) + (highlight-region pane offset1 (offset mark2) ink)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; exploit the parse --- /project/climacs/cvsroot/climacs/core.lisp 2006/09/02 10:17:52 1.6 +++ /project/climacs/cvsroot/climacs/core.lisp 2006/09/02 21:43:56 1.7 @@ -459,7 +459,7 @@ :test (lambda (x y) (member x y :test #'string-equal)) :key #'climacs-syntax::syntax-description-pathname-types)) - 'basic-syntax)) + *default-syntax*)) (defun evaluate-attributes (buffer options) "Evaluate the attributes `options' and modify `buffer' as @@ -627,10 +627,6 @@ (make-buffer-from-stream stream *application-frame*)) (make-new-buffer *application-frame*))) (pane (current-window))) - ;; Clear the pane's cache; otherwise residue from the - ;; previously displayed buffer may under certain - ;; circumstances be displayed. - (clear-cache pane) (setf (offset (point (buffer pane))) (offset (point pane)) (buffer (current-window)) buffer (syntax buffer) (make-instance (syntax-class-name-for-filepath filepath) --- /project/climacs/cvsroot/climacs/cl-syntax.lisp 2006/06/12 19:10:58 1.19 +++ /project/climacs/cvsroot/climacs/cl-syntax.lisp 2006/09/02 21:43:56 1.20 @@ -111,7 +111,7 @@ (make-instance 'other-entry)))))))) -(define-syntax cl-syntax (basic-syntax) +(define-syntax cl-syntax (fundamental-syntax) ((lexer :reader lexer) (valid-parse :initform 1) (parser)) From thenriksen at common-lisp.net Sun Sep 3 20:04:20 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Sep 2006 16:04:20 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060903200420.96B386000E@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv23423 Modified Files: motion.lisp Log Message: Catch buffer motion conditions in `forward-one-line' and `backward-one-line'. --- /project/climacs/cvsroot/climacs/motion.lisp 2006/07/25 11:38:05 1.2 +++ /project/climacs/cvsroot/climacs/motion.lisp 2006/09/03 20:04:19 1.3 @@ -290,10 +290,11 @@ (defmethod forward-one-line (mark syntax) (let ((column (column-number mark))) (end-of-line mark) - (cond ((forward-object mark) - (setf (column-number mark) column) - t) - (t nil)))) + (handler-case (cond ((forward-object mark) + (setf (column-number mark) column) + t) + (t nil)) + (motion-after-end ())))) (defgeneric backward-one-line (mark syntax) (:documentation @@ -303,10 +304,11 @@ (defmethod backward-one-line (mark syntax) (let ((column (column-number mark))) (beginning-of-line mark) - (cond ((backward-object mark) - (setf (column-number mark) column) - t) - (t nil)))) + (handler-case (cond ((backward-object mark) + (setf (column-number mark) column) + t) + (t nil)) + (motion-before-beginning ())))) (define-motion-fns line) From thenriksen at common-lisp.net Sun Sep 3 21:22:05 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Sep 2006 17:22:05 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060903212205.DE2437D0BD@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv5873 Modified Files: packages.lisp esa-io.lisp Log Message: `current-buffer' should not take required arguments, but we still need to be able to do per-application method dispatch. So introduce `frame-current-buffer'. --- /project/climacs/cvsroot/esa/packages.lisp 2006/08/20 10:08:23 1.6 +++ /project/climacs/cvsroot/esa/packages.lisp 2006/09/03 21:22:05 1.7 @@ -25,7 +25,7 @@ (defpackage :esa-io (:use :clim-lisp :clim :esa :esa-buffer) - (:export #:buffers #:current-buffer + (:export #:buffers #:frame-current-buffer #:current-buffer #:find-file #:find-file-read-only #:set-visited-filename #:save-buffer #:write-buffer --- /project/climacs/cvsroot/esa/esa-io.lisp 2006/08/20 10:43:40 1.4 +++ /project/climacs/cvsroot/esa/esa-io.lisp 2006/09/03 21:22:05 1.5 @@ -23,9 +23,14 @@ (defgeneric buffers (application-frame) (:documentation "Return a list of all the buffers of the application")) -(defgeneric current-buffer (application-frame) +(defgeneric frame-current-buffer (application-frame) (:documentation "Return the current buffer of APPLICATION-FRAME")) +(defun current-buffer (&optional (frame *application-frame*)) + "Return the current buffer of `frame'. This function merely +calls `frame-current-buffer' with `frame' as argument." + (frame-current-buffer frame)) + (defgeneric find-file (file-path application-frame)) (defgeneric find-file-read-only (file-path application-frame)) (defgeneric set-visited-filename (filepath buffer application-frame)) @@ -164,7 +169,7 @@ (make-pathname :directory (pathname-directory - (or (filepath (current-buffer *application-frame*)) + (or (filepath (current-buffer)) (user-homedir-pathname))))) (define-command (com-find-file :name t :command-table esa-io-table) @@ -226,7 +231,7 @@ "Toggle the readonly status of the current buffer. When a buffer is readonly, attempts to change the contents of the buffer signal an error." - (let ((buffer (current-buffer *application-frame*))) + (let ((buffer (current-buffer))) (setf (read-only-p buffer) (not (read-only-p buffer))))) (set-key 'com-read-only 'esa-io-table '((#\x :control) (#\q :control))) @@ -246,7 +251,7 @@ "Prompt for a new filename for the current buffer. The next time the buffer is saved it will be saved to a file with that filename." - (set-visited-file-name filename (current-buffer *application-frame*) *application-frame*)) + (set-visited-file-name filename (current-buffer) *application-frame*)) (defun extract-version-number (pathname) "Extracts the emacs-style version-number from a pathname." @@ -312,7 +317,7 @@ "Write the contents of the buffer to a file. If there is filename associated with the buffer, write to that file, replacing its contents. If not, prompt for a filename." - (let ((buffer (current-buffer *application-frame*))) + (let ((buffer (current-buffer))) (if (or (null (filepath buffer)) (needs-saving buffer)) (save-buffer buffer *application-frame*) @@ -338,7 +343,7 @@ :default-type 'pathname)) "Prompt for a filename and write the current buffer to it. Changes the file visted by the buffer to the given file." - (let ((buffer (current-buffer *application-frame*))) + (let ((buffer (current-buffer))) (write-buffer buffer filepath *application-frame*))) (set-key `(com-write-buffer ,*unsupplied-argument-marker*) From thenriksen at common-lisp.net Sun Sep 3 21:23:30 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Sep 2006 17:23:30 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060903212330.208437C016@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv6017 Modified Files: packages.lisp gui.lisp Log Message: Implement `frame-current-buffer' and define and export `current-mark'. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/09/02 21:43:56 1.113 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/03 21:23:29 1.114 @@ -334,6 +334,7 @@ #:current-point #:current-buffer #:current-point + #:current-mark #:point #:syntax #:mark --- /project/climacs/cvsroot/climacs/gui.lisp 2006/08/20 13:06:39 1.228 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/09/03 21:23:29 1.229 @@ -202,7 +202,11 @@ "Return the current panes point." (point (current-window))) -(defmethod current-buffer ((application-frame climacs)) +(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)))) From thenriksen at common-lisp.net Mon Sep 4 07:04:29 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Sep 2006 03:04:29 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060904070429.B923F3C010@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv3573 Modified Files: buffer.lisp Log Message: `(setf column-number)' now returns the column. --- /project/climacs/cvsroot/climacs/buffer.lisp 2006/06/12 19:10:58 1.34 +++ /project/climacs/cvsroot/climacs/buffer.lisp 2006/09/04 07:04:29 1.35 @@ -425,13 +425,17 @@ (buffer-column-number (buffer mark) (offset mark))) (defgeneric (setf column-number) (number mark) - (:documentation "Set the column number of the mark.")) + (:documentation "Set the column number of the mark, return the + column number. Note that if `number' is larger than the length + of the line `mark' is in, `mark' will be moved to end of + line.")) (defmethod (setf column-number) (number mark) (beginning-of-line mark) (loop repeat number until (end-of-line-p mark) - do (incf (offset mark)))) + do (incf (offset mark)) + finally (return (column-number mark)))) (defgeneric insert-buffer-object (buffer offset object) (:documentation "Insert the object at the offset in the buffer. Any left-sticky marks From thenriksen at common-lisp.net Mon Sep 4 07:05:21 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Sep 2006 03:05:21 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060904070521.CB9653E00F@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv3863 Modified Files: packages.lisp base.lisp Log Message: Add `move-to-column' function to CLIMACS-BASE. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/09/03 21:23:29 1.114 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/04 07:05:21 1.115 @@ -89,6 +89,7 @@ #:number-of-lines-in-region #:constituentp #:just-n-spaces + #:move-to-column #:buffer-whitespacep #:buffer-region-case #:name-mixin #:name --- /project/climacs/cvsroot/climacs/base.lisp 2006/08/28 17:22:58 1.59 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/09/04 07:05:21 1.60 @@ -266,6 +266,17 @@ (- existing-spaces n)) mark1)))))) +(defun move-to-column (mark column &optional force) + "Move the position of `mark' to column number `column'. If the + line is too short, put `mark' at end of line, unless `force' is + non-NIL, in which case spaces will be added to the end of the + line." + (let ((set-column (setf (column-number mark) column))) + (when (and (not (= set-column column)) + force) + (insert-sequence mark (make-string (- column set-column) + :initial-element #\Space))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Character case From thenriksen at common-lisp.net Mon Sep 4 09:00:31 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Sep 2006 05:00:31 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060904090031.CB0262D053@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv26441 Modified Files: packages.lisp misc-commands.lisp Added Files: rectangle.lisp Log Message: Added GNU Emacs-style rectangle editing. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/09/04 07:05:21 1.115 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/04 09:00:30 1.116 @@ -420,7 +420,17 @@ #:input-from-stream #:save-buffer-to-stream - #:make-buffer-from-stream) + #:make-buffer-from-stream + + #:*killed-rectangle* + #:map-rectangle-lines + #:extract-and-delete-rectangle-line + #:insert-rectangle-at-mark + #:clear-rectangle-line + #:open-rectangle-line + #:replace-rectangle-line + #:insert-in-rectangle-line + #:delete-rectangle-line-whitespace) (:documentation "Package for editor functionality that is syntax-aware, but yet not specific to certain syntaxes. Contains stuff like indentation, filling and other --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/09/02 10:17:52 1.23 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/09/04 09:00:30 1.24 @@ -755,3 +755,108 @@ (define-command (com-visible-region :name t :command-table marking-table) () "Toggle the visibility of the region in the current pane." (setf (region-visible-p (current-window)) (not (region-visible-p (current-window))))) + +(define-command (com-kill-rectangle :name t :command-table deletion-table) + () + "Kill the rectangle bounded by current point and mark. + +The rectangle will be put in a rectangle kill buffer, from which it can +later be yanked with Yank Rectangle. This kill buffer is completely +disjunct from the standard kill ring and can only hold a single rectangle at a time." + (setf *killed-rectangle* + (map-rectangle-lines (current-buffer) + #'extract-and-delete-rectangle-line + (current-point) + (current-mark)))) + +(set-key 'com-kill-rectangle + 'deletion-table + '((#\x :control) (#\r) (#\k))) + +(define-command (com-delete-rectangle :name t :command-table deletion-table) + () + "Delete the rectangle bounded by current point and mark. + +The rectangle will be deleted and NOT put in the kill buffer." + (map-rectangle-lines (current-buffer) + #'extract-and-delete-rectangle-line + (current-point) + (current-mark))) + +(set-key 'com-delete-rectangle + 'deletion-table + '((#\x :control) (#\r) (#\d))) + +(define-command (com-yank-rectangle :name t :command-table editing-table) + () + "Insert the rectangle from the rectangle kill buffer at mark. + +The rectangle kill buffer will not be emptied, so it is possible to yank +the same rectangle several times." + (insert-rectangle-at-mark (current-buffer) + (current-point) + *killed-rectangle*)) + +(set-key 'com-yank-rectangle + 'editing-table + '((#\x :control) (#\r) (#\y))) + +(define-command (com-clear-rectangle :name t :command-table deletion-table) + () + "Clear the rectangle bounded by current point and mark by filling it with spaces." + (map-rectangle-lines (current-buffer) + #'clear-rectangle-line + (current-point) + (current-mark))) + +(set-key 'com-clear-rectangle + 'editing-table + '((#\x :control) (#\r) (#\c))) + +(define-command (com-open-rectangle :name t :command-table editing-table) + () + "Open the rectangle bounded by current point and mark. + +The rectangle will not be deleted, but instead pushed to the right, with +the area previously inhabited by it filled with spaces." + (map-rectangle-lines (current-buffer) + #'open-rectangle-line + (current-point) + (current-mark))) + +(set-key 'com-open-rectangle + 'editing-table + '((#\x :control) (#\r) (#\o))) + +(define-command (com-string-rectangle :name t :command-table editing-table) + ((string 'string :prompt "String rectangle")) + "Replace each line of the rectangle bounded by current point of mark with `string'. + +The length of the string need not be equal to the width of the rectangle." + (map-rectangle-lines (current-buffer) + #'(lambda (mark startcol endcol) + (replace-rectangle-line mark startcol endcol string)) + (current-point) + (current-mark))) + +(set-key 'com-string-rectangle + 'editing-table + '((#\x :control) (#\r) (#\t))) + +(define-command (com-string-insert-rectangle :name t :command-table editing-table) + ((string 'string :prompt "String rectangle")) + "Insert `string' in each line of the rectangle bounded by current point of mark. + +Text in the rectangle will be shifted right." + (map-rectangle-lines (current-buffer) + #'(lambda (mark startcol endcol) + (insert-in-rectangle-line mark startcol endcol string)) + (current-point) + (current-mark))) + +(define-command (com-delete-whitespace-rectangle :name t :command-table editing-table) + () + (map-rectangle-lines (current-buffer) + #'delete-rectangle-line-whitespace + (current-point) + (current-mark))) --- /project/climacs/cvsroot/climacs/rectangle.lisp 2006/09/04 09:00:31 NONE +++ /project/climacs/cvsroot/climacs/rectangle.lisp 2006/09/04 09:00:31 1.1 ;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*- ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas at 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. ;;; Implementation of rectangle editing. (in-package :climacs-core) (defvar *killed-rectangle* nil "The killed rectangle as a list of lines.") (defun map-rectangle-lines (buffer function start end) "Map over lines in rectangle, calling `function' for each line. The rectangle is defined by the marks `start' and `end'. For each line, `function' will be called with arguments of a mark situated at the beginning of the line, the starting column of the rectangle and the ending column of the rectangle. This function returns a list of the return values of `function'." (let ((startcol (column-number start)) (endcol (column-number end)) (mark (clone-mark (point buffer)))) (when (> startcol endcol) (rotatef startcol endcol)) (when (mark> start end) (rotatef start end)) (setf (offset mark) (offset start)) (loop do (beginning-of-line mark) until (mark> mark end) collect (funcall function (clone-mark mark) startcol endcol) until (not (forward-line mark (syntax buffer) 1 nil))))) (defmacro with-bounding-marks (((start-mark end-mark) mark startcol endcol &key force-start force-end) &body body) "Evaluate `body' with `start-mark' and `end-mark' bound to marks delimiting the rectangle area. The rectangle area is defined as the part of the line that `mark' is situated in, that lies between the columns `startcol' and `endcol'. If `force-start' or `force-end' is non-NIL, the line will be padded with space characters in order to put `start-mark' or `end-mark' at their specified columns respectively." (let ((mark-val-sym (gensym)) (startcol-val-sym (gensym)) (endcol-val-sym (gensym))) `(progn (let ((,mark-val-sym ,mark) (,startcol-val-sym ,startcol) (,endcol-val-sym ,endcol)) (move-to-column ,mark-val-sym ,startcol-val-sym ,force-start) (let ((,start-mark (clone-mark ,mark-val-sym))) (let ((,end-mark (clone-mark ,mark-val-sym))) (move-to-column ,end-mark ,endcol-val-sym ,force-end) , at body)))))) (defun extract-and-delete-rectangle-line (mark startcol endcol) "For the line that `mark' is in, delete and return the string between column `startcol' and `endcol'. If the string to be returned is not as wide as the rectangle, it will be right-padded with space characters." (with-bounding-marks ((start-mark end-mark) mark startcol endcol) (let ((str (concatenate 'string (buffer-substring (buffer mark) (offset start-mark) (offset end-mark)) (make-string (- endcol (column-number end-mark)) :initial-element #\Space)))) (delete-range start-mark (- (offset end-mark) (offset start-mark))) str))) (defun delete-rectangle-line (mark startcol endcol) "For the line that `mark' is in, delete the string between column `startcol' and `endcol'." (with-bounding-marks ((start-mark end-mark) mark startcol endcol) (delete-range start-mark (- (offset end-mark) (offset start-mark))))) (defun open-rectangle-line (mark startcol endcol) "For the line that `mark' is in, move the string between column `startcol' and `endcol' to the right, replacing the area previously inhabited by it with space characters." (with-bounding-marks ((start-mark end-mark) mark startcol endcol) (unless (mark= start-mark end-mark) (insert-sequence start-mark (make-string (- endcol startcol) :initial-element #\Space))))) (defun clear-rectangle-line (mark startcol endcol) "For the line that `mark' is in, replace the string between column `startcol' and `endcol' with space characters." (with-bounding-marks ((start-mark end-mark) mark startcol endcol) (let ((size (- (offset end-mark) (offset start-mark)))) (delete-range start-mark size) (insert-sequence start-mark (make-string size :initial-element #\Space))))) (defun delete-rectangle-line-whitespace (mark startcol endcol) "For the line that `mark' is in, delete all whitespace characters from `startcol' up to the first non-whitespace character." (with-bounding-marks ((start-mark end-mark) mark startcol endcol) (let ((target-mark (clone-mark start-mark))) (re-search-forward target-mark "[^ ]") (when (= (line-number start-mark) (line-number target-mark)) (delete-range start-mark (- (offset target-mark) (offset start-mark) 1)))))) (defun replace-rectangle-line (mark startcol endcol string) "For the line that `mark' is in, replace the string between column `startcol' and `endcol' with `string'." (with-bounding-marks ((start-mark end-mark) mark startcol endcol :force-start t) (delete-range start-mark (- (offset end-mark) (offset start-mark))) (insert-sequence start-mark string))) (defun insert-in-rectangle-line (mark startcol endcol string) "For the line that `mark' is in, move the string between column `startcol' and `endcol' to the right, replacing the area previously inhabited by it with the contents of `string'." (with-bounding-marks ((start-mark end-mark) mark startcol endcol :force-start t) (insert-sequence start-mark string))) (defun insert-rectangle-at-mark (buffer mark rectangle) "Yank the killed rectangle, positioning the upper left corner at current point." (let ((insert-column (column-number mark))) (dolist (line rectangle) (move-to-column mark insert-column t) (insert-sequence mark line) (unless (forward-line mark (syntax buffer) 1 nil) (open-line mark) (forward-object mark))))) From thenriksen at common-lisp.net Mon Sep 4 09:18:15 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Sep 2006 05:18:15 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060904091815.882707D092@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv29451 Modified Files: climacs.asd Log Message: Oops. Added rectangle.lisp to climacs.asd. --- /project/climacs/cvsroot/climacs/climacs.asd 2006/08/20 13:06:39 1.51 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/09/04 09:18:14 1.52 @@ -96,6 +96,7 @@ "abbrev" "editing" "motion")) (:file "io" :depends-on ("packages" "gui")) (:file "core" :depends-on ("gui")) + (:file "rectangle" :depends-on ("core")) (:file "climacs" :depends-on ("gui" "core")) ;; (:file "buffer-commands" :depends-on ("gui")) (:file "developer-commands" :depends-on ("gui" "lisp-syntax" "core")) From thenriksen at common-lisp.net Wed Sep 6 17:42:08 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 6 Sep 2006 13:42:08 -0400 (EDT) Subject: [climacs-cvs] CVS climacs/Doc Message-ID: <20060906174208.ED6526D02A@common-lisp.net> Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv10579/Doc Modified Files: climacs-user.texi Log Message: Load rectangle.lisp before misc-commands.lisp to silence warning. --- /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/24 17:58:32 1.13 +++ /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/09/06 17:42:08 1.14 @@ -42,6 +42,7 @@ * Basic editing commands:: * Different editing modes:: * Kill ring:: +* Groups:: * Advanced editing commands:: * Getting help:: * Proposal for new buffer/pane relations:: @@ -533,6 +534,94 @@ objects on a global @emph{kill ring}. @cindex kill ring + at node Groups + at chapter Groups + + at menu +* The group metaphor:: +* Group commands:: + at end menu + + at node The group metaphor + at section The group metaphor + + at climacs{} supports a useful and powerful concept called @emph{groups}. + at cindex group +Groups are conceptually just lists of buffers or files, and when used in +conjunction with a command, means that the command operates on all +buffers or files designated by the group. For example, a +string-replaceable command might perform string-replacement in several +buffers, and not just the current one. A command that supports +operations on multiple files or buffers at a time, via groups, is called +a @emph{group-aware command}. + at cindex group-aware command. +However, a group is not limited to designating a simple list of static +elements, the exact elements designated by a group may depend on the +context in which a group-using command is invoked - for example, a group +may designate ``all files in the same directory as the current +buffer''. In this case, the specific files designated by the group can +change if the user switches to another buffer. Every group has a unique +name and all references to the group are performed with this name as the +key. + +At all times, Climacs may have an @emph{active group}. + at cindex active group +The active group is used to control the scope of effect of group-aware +commands - when such a command is executed, it will look at the active +group to get a list of files and buffers, and perform its operations on +all elements in the group. The exact behavior of commands with respect +to groups is dependent on the command itself, though. The act of setting +the active group is called @emph{selecting a group}, + at cindex selecting a group +specifically, selecting the group that is set as the active group. It is +also possible to deselect the active group, in which case most +group-aware commands will simply perform their operations on the current +buffer. + +Specifically, there are two different kind of groups - @emph{specific +groups} + at cindex specific groups +and @emph{persistent groups}. + at cindex persistent groups +Specific groups can be defined by the user through the command +interface, @pxref{Group commands}. They are simple lists of buffers or +files, and if a buffer named in a group is killed, it will be removed +from the group. Creating a buffer with the same name, or the same file, +will not result in the buffer being re-added to the group. Specific +groups are also lost when @climacs{} is terminated. Persistent groups, +on the other hand, are usually pre-defined groups with more complex +behavior. Their exact list of designated files and buffers is usually +context-dependent and not calculated until they are needed. It is not +currently possible to define persistent groups through the command +interface, though some persistent groups support user-defined filters +and options. When a persistent group is selected as the active group, it +may query the user for values - for example, a persistent group +designating all files in a given directory, may ask the user for a +directory when it is selected. + + at node Group commands + at section Group commands + +Specific groups can be defined by using the order @kbd{C-x g d} + at kindex C-x g d +(@command{Define Group}). You will be queried for a name for the group +and a list of buffers, and a group with the specified name and buffers +will be created and selected as the active group. Alternatively, you can +use the order @kbd{C-x g f} + at kindex C-x g f +(@command{Define File Group}, which will query for files instead of +buffers. If you wish to select an already existing group (persistent or +specific) as the active group, you can use the order @kbd{C-x g s}. + at kindex C-x g s +You can deselect the active group with the order @kbd{C-x g u} + at kindex C-x g u +(@command{Deselect Group}) - this will usually make all group-aware +commands operate on just the current buffer. To see which group is the +active group, use the order @kbd{C-x g c} + at kindex C-x g c +(@command{Current Group}), and to see the buffers and files designated +by the active group, use @kbd{C-x g l} (@command{List Group Contents}). + @node Advanced editing commands @chapter Advanced editing commands From thenriksen at common-lisp.net Wed Sep 6 17:42:09 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 6 Sep 2006 13:42:09 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060906174209.3CCF470212@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv10579 Modified Files: climacs.asd Log Message: Load rectangle.lisp before misc-commands.lisp to silence warning. --- /project/climacs/cvsroot/climacs/climacs.asd 2006/09/04 09:18:14 1.52 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/09/06 17:42:08 1.53 @@ -103,7 +103,7 @@ (:file "motion-commands" :depends-on ("gui" "core")) (:file "editing-commands" :depends-on ("gui" "core")) (:file "file-commands" :depends-on ("gui" "core")) - (:file "misc-commands" :depends-on ("gui" "core")) + (:file "misc-commands" :depends-on ("gui" "core" "rectangle")) (:file "search-commands" :depends-on ("gui" "core")) (:file "window-commands" :depends-on ("gui" "core")) (:file "unicode-commands" :depends-on ("gui" "core")) From thenriksen at common-lisp.net Wed Sep 6 20:07:21 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 6 Sep 2006 16:07:21 -0400 (EDT) Subject: [climacs-cvs] CVS climacs/Doc Message-ID: <20060906200721.65FF636017@common-lisp.net> Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv26720/Doc Modified Files: climacs-internals.texi Log Message: Added Group functionality to Climacs (the additions to the User Manual was erroneously part of my previous commit). Needs testing and better support from search/replace commands. --- /project/climacs/cvsroot/climacs/Doc/climacs-internals.texi 2006/07/27 13:58:57 1.22 +++ /project/climacs/cvsroot/climacs/Doc/climacs-internals.texi 2006/09/06 20:07:21 1.23 @@ -46,8 +46,9 @@ @chapter Introduction -You are reading the Climacs internals manual. This document contains -a detailed description of various Climacs protocols. +You are reading the Climacs internals manual. This document contains a +detailed description of various Climacs protocols and other internal +details. @chapter Buffer protocol @@ -2100,7 +2101,188 @@ flexicursor assocated with kill-ring. @end deffn + at chapter Group facilities + + at section Overview + +The Climacs group functionality is implemented through a simple protocol +that permits the definition of new kinds of groups, as well as a number +of utility functions and macros based on the protocol. Specific groups +are stored in an @code{equalp} hash table in the Climacs frame object +with groups keyed by their name as a string (the choice of @code{equalp} +as the hash table test means that group names are not +case-sensitive). Persistent groups are stored in a global @code{equalp} +hash table, also keyed by the name of the group as a string. + at footnote{The use of a global hash table means that two Climacs sessions +running in the same image might clobber each others group settings - +this is bad and indicative of a larger problem regarding running +multiple Climacs sessions.} The active group is also stored in the +Climacs frame object, typically as a ``synonym'' group, that forwards +protocol methods to a group with a specified name. This is done so that +it is possible to redefine a specific group while it is selected, and +have the changes reflected in the selected group. Since redefinition of +a group merely means creating and inserting a new object for the key in +the hash table, the slot in the Climacs frame object would continue to +refer to the old definition of the group, if this added indirection was +not done. + +The group protocol and its implementation is still very basic, and may +fail when faced with situations such as file access rights changing and +killing of buffers at unpredicted times. + + at section Basic group protocol + + at deftp {Protocol Class} group +The base class for all group objects. This class is not meant to be +instantiated. + at end deftp + + at deftp {Initarg} :name +The name of the group. The @var{:name} initarg is mandatory, because +every group must have a name. + at end deftp + + at deftp {Class} group-element +Objects of this class designate a single element, either a buffer or a +file. A subclass of @code{group}. + at end deftp + + at deftp {Initarg} :element +This initarg provides the element that the @code{group-element} instance +should designate. + at end deftp + + at deftp {Class} standard-group +Objects of this class designate a sequence of elements, normally +instances of @code{group-element}. + at end deftp + + at deftp {Initarg} :elements +This initarg provides the elements that the @code{standard-group} +instance should designate. + at end deftp + + at deftp {Class} current-buffer-group +Objects of this class designate the ``current buffer''. That is, +whenever instances of this class are queried for a list of buffers (for +example, via @code{group-buffers}), they will respond with a list of one +element, the currently active buffer. + at end deftp + + at deffn {Generic Function} {group-buffers} group +Get a list of buffers in @var{group}. Only already existing buffers will +be returned, use @code{ensure-group-buffers} if you want all buffers +defined by the group. + at end deffn + + at deffn {Generic Function} {ensure-group-buffers} group +For each pathname in @var{group} that does not have a corresponding +buffer, open a buffer for that pathname. + at end deffn + + at deffn {Generic Function} {select-group} group +Tell the group object @var{group} that the user has selected it. This +method is responsible for setting the active group. If @var{group} needs +additional information, it should query the user when this method is +invoked. The standard method should be sufficient for most group +classes. + at end deffn + + at deffn {Generic Function} {display-group-contents} group +Display the contents of @var{group} to @var{stream}. Basically, this +should describe which buffers or files would be affected by group-aware +commands if @var{group} was the active group. There is no standard +format for the output, but it is intended for displaying to the user. It +is acceptable to only define methods where @var{stream} is a CLIM + at code{extended-output-stream}. + at end deffn + + at section Group management + +A number of functions are provided to manage definition and management +of groups. It is not possible to remove groups (excluding using + at code{remhash} explicitly), but there are functions to add and get groups +based on their name. + + at deffn {Function} {add-group} name elements +Define a group called @var{name} (a string) containing the elements + at var{elements}, which must be a list of pathnames and/or buffers, and +add it to the list of defined groups. + at end deffn + + at deffn {Function} {get-group} name +Return the group with the name @var{name}. + at end deffn + + at deffn {Function} {get-active-group} +Return the currently active group. + at end deffn + + at deffn {Function} {deselect-group} +Deselect the currently active group. + at end deffn + + at section Expanded group facilities + +On top of the basic protocol, a number of additional and useful classes, +functions and macros have been defined. + + at deffn {Macro} {with-group-buffers} (buffers group &key keep) &body body +Make sure that all files designated by @var{group} are open in buffers +during the evaluation of @var{body}. If @var{keep} is NIL, all buffers +created by this macro will be saved and killed after @var{body} has +run. Also, @var{buffers} will be bound to a list of the buffers +containing the files designated by @var{group} while @var{body} is run. + at end deffn + + at deffn {Macro} {define-group} (name (group-arg &rest args) &body body) +Define a persistent group named @var{name}. @var{Body} should return a +list of pathnames and will be used to calculate which files are +designated by the group. @var{Args} should be two-element lists, with +the first element bound to the result of evaluating the second +element. The second element will be evaluated when the group is +selected to be the active group by the user. @node Index + + at deftp {Error Condition} group-not-found +This condition is signaled whenever a synonym group is unable to find +the group that it is supposed to forward method invocations to. + at end deftp + + at deftp {Method} {group-name} (condition @code{group-not-found}) +When invoked, this method returns the name of the group that could not +be found. + at end deftp + + at deftp {Class} synonym-group +Objects of this class forwards all calls of group protocol methods to a +group with a specified name. If a group of the requested name cannot be +found, a condition of type @code{group-not-found} will be signalled. + at end deftp + + at deftp {Initarg} :other-name +The name of the buffer an instance of @code{synonym-group} should +forward method calls to. + at end deftp + + at deftp {Class} custom-group +Instances of this class will call a provided function when it is +selected or asked for pathnames. + at end deftp + + at deftp {Initarg} :pathname-lister +The function that will be called for the @code{custom-group} object to +retrieve the pathnames that the group designates. This should be a +function of one required argument, the group object, and it should +return a list of pathname objects. + at end deftp + + at deftp {Initarg} :select-response +The function that will be called when the @code{custom-group} object is +selected as the active group. This should be a function of a single +required argument, the group object, and it is called for side effects. + at end deftp + @unnumbered Index @printindex cp From thenriksen at common-lisp.net Wed Sep 6 20:07:22 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 6 Sep 2006 16:07:22 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060906200722.55B553900A@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv26720 Modified Files: search-commands.lisp packages.lisp misc-commands.lisp gui.lisp core.lisp climacs.asd Added Files: groups.lisp Log Message: Added Group functionality to Climacs (the additions to the User Manual was erroneously part of my previous commit). Needs testing and better support from search/replace commands. --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/08/20 13:06:38 1.13 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/09/06 20:07:21 1.14 @@ -317,15 +317,19 @@ (with-accessors ((string string1) (buffers buffers) (mark mark)) state - (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) - (switch-to-buffer (first buffers)) - (setf mark (point (first buffers))) - (beginning-of-buffer mark) - (query-replace-find-next-match state)))))) + (flet ((head-to-buffer (buffer) + (switch-to-buffer 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)) @@ -357,19 +361,20 @@ (point (point pane)) (occurrences 0)) (declare (special string1 string2 occurrences)) - (setf (query-replace-state pane) (make-instance 'query-replace-state - :string1 string1 - :string2 string2 - :mark point - :buffers (list (buffer pane)))) - (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))) + (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 --- /project/climacs/cvsroot/climacs/packages.lisp 2006/09/04 09:00:30 1.116 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/06 20:07:21 1.117 @@ -340,6 +340,8 @@ #:syntax #:mark #:buffers + #:active-group + #:groups #:insert-character #:display-window #:split-window @@ -430,7 +432,23 @@ #:open-rectangle-line #:replace-rectangle-line #:insert-in-rectangle-line - #:delete-rectangle-line-whitespace) + #:delete-rectangle-line-whitespace + + #:group + #:group-element + #:standard-group + #:current-buffer-group + #:add-group + #:get-group + #:get-active-group + #:deselect-group + #:with-group-buffers + #:define-group + #:group-not-found + #:group-buffers + #:ensure-group-buffers + #:select-group + #:display-group-contents) (:documentation "Package for editor functionality that is syntax-aware, but yet not specific to certain syntaxes. Contains stuff like indentation, filling and other --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/09/04 09:00:30 1.24 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/09/06 20:07:21 1.25 @@ -756,6 +756,10 @@ "Toggle the visibility of the region in the current pane." (setf (region-visible-p (current-window)) (not (region-visible-p (current-window))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Rectangle editing + (define-command (com-kill-rectangle :name t :command-table deletion-table) () "Kill the rectangle bounded by current point and mark. @@ -860,3 +864,68 @@ #'delete-rectangle-line-whitespace (current-point) (current-mark))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Groups + +(define-command (com-define-group :name t :command-table global-climacs-table) + ((name 'string :prompt "Name") + (buffers '(sequence climacs-buffer) :prompt "Buffers")) + (when (or (not (get-group name)) + (accept 'boolean :prompt "Group already exists. Overwrite existing group?")) + (add-group name buffers)) + (select-group (get-group name))) + +(set-key `(com-define-group ,*unsupplied-argument-marker* ,*unsupplied-argument-marker*) + 'global-climacs-table + '((#\x :control) (#\g) (#\d))) + +(define-command (com-define-file-group :name t :command-table global-climacs-table) + ((name 'string :prompt "Name") + (pathnames '(sequence pathname) :prompt "Files")) + (when (or (not (get-group name)) + (accept 'boolean :prompt "Group already exists. Overwrite existing group?")) + (add-group name pathnames)) + (select-group (get-group name))) + +(set-key `(com-define-file-group ,*unsupplied-argument-marker* ,*unsupplied-argument-marker*) + 'global-climacs-table + '((#\x :control) (#\g) (#\f))) + +(define-command (com-select-group :name t :command-table global-climacs-table) + ((group 'group)) + (select-group group)) + +(set-key `(com-select-group ,*unsupplied-argument-marker*) + 'global-climacs-table + '((#\x :control) (#\g) (#\s))) + +(define-command (com-deselect-group :name t :command-table global-climacs-table) + () + (deselect-group) + (display-message "Group deselected")) + +(set-key 'com-deselect-group + 'global-climacs-table + '((#\x :control) (#\g) (#\u))) + +(define-command (com-current-group :name t :command-table global-climacs-table) + () + (with-minibuffer-stream (s) + (format s "Active group is: ") + (present (get-active-group) 'group :stream s))) + +(set-key 'com-current-group + 'global-climacs-table + '((#\x :control) (#\g) (#\c))) + +(define-command (com-list-group-contents :name t :command-table global-climacs-table) + () + (with-minibuffer-stream (s) + (format s "Active group designates: ") + (display-group-contents (get-active-group) s))) + +(set-key 'com-list-group-contents + 'global-climacs-table + '((#\x :control) (#\g) (#\l))) \ No newline at end of file --- /project/climacs/cvsroot/climacs/gui.lisp 2006/09/03 21:23:29 1.229 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/09/06 20:07:21 1.230 @@ -130,6 +130,8 @@ (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)) (:command-table (global-climacs-table :inherit-from (global-esa-table --- /project/climacs/cvsroot/climacs/core.lisp 2006/09/02 21:43:56 1.7 +++ /project/climacs/cvsroot/climacs/core.lisp 2006/09/06 20:07:21 1.8 @@ -596,6 +596,33 @@ (and (or (null name) (eql name :unspecific)) (or (null type) (eql type :unspecific))))) +(defun findablep (pathname) + "Return non-NIL if `pathname' can be opened by Climacs. That + is, check whether the file exists and is not a directory." + (and (probe-file pathname) + (not (directory-pathname-p pathname)))) + +(defun find-buffer-with-pathname (pathname) + "Return the (first) buffer associated with the file designated +by `pathname'. Returns NIL if no buffer can be found." + (flet ((usable-pathname (pathname) + (if (probe-file pathname) + (truename pathname) + pathname))) + (find pathname (buffers *application-frame*) + :key #'filepath + :test #'(lambda (fp1 fp2) + (and fp1 fp2 + (equal (usable-pathname fp1) + (usable-pathname fp2))))))) + +(defun ensure-open-file (pathname) + "Make sure a buffer opened on `pathname' exists, finding the +file if necessary." + (when (and (findablep pathname) + (not (find-buffer-with-pathname pathname))) + (find-file pathname *application-frame*))) + (defun find-file-impl (filepath &optional readonlyp) (cond ((null filepath) (display-message "No file name given.") @@ -604,42 +631,33 @@ (display-message "~A is a directory name." filepath) (beep)) (t - (flet ((usable-pathname (pathname) - (if (probe-file pathname) - (truename pathname) - pathname))) - (let ((existing-buffer (find filepath (buffers *application-frame*) - :key #'filepath - :test #'(lambda (fp1 fp2) - (and fp1 fp2 - (equal (usable-pathname fp1) - (usable-pathname fp2))))))) - (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t)) - (switch-to-buffer existing-buffer) - (progn - (when readonlyp - (unless (probe-file filepath) - (beep) - (display-message "No such file: ~A" filepath) - (return-from find-file-impl nil))) - (let ((buffer (if (probe-file filepath) - (with-open-file (stream filepath :direction :input) - (make-buffer-from-stream stream *application-frame*)) - (make-new-buffer *application-frame*))) - (pane (current-window))) - (setf (offset (point (buffer pane))) (offset (point pane)) - (buffer (current-window)) buffer - (syntax buffer) (make-instance (syntax-class-name-for-filepath filepath) - :buffer buffer) - (file-write-time buffer) (file-write-date filepath)) - (evaluate-attribute-line buffer) - (setf (filepath buffer) filepath - (name buffer) (filepath-filename filepath) - (read-only-p buffer) readonlyp) - (beginning-of-buffer (point pane)) - (update-syntax buffer (syntax buffer)) - (clear-modify buffer) - buffer)))))))) + (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) + (progn + (when readonlyp + (unless (probe-file filepath) + (beep) + (display-message "No such file: ~A" filepath) + (return-from find-file-impl nil))) + (let ((buffer (if (probe-file filepath) + (with-open-file (stream filepath :direction :input) + (make-buffer-from-stream stream *application-frame*)) + (make-new-buffer *application-frame*))) + (pane (current-window))) + (setf (offset (point (buffer pane))) (offset (point pane)) + (buffer (current-window)) buffer + (syntax buffer) (make-instance (syntax-class-name-for-filepath filepath) + :buffer buffer) + (file-write-time buffer) (file-write-date filepath)) + (evaluate-attribute-line buffer) + (setf (filepath buffer) filepath + (name buffer) (filepath-filename filepath) + (read-only-p buffer) readonlyp) + (beginning-of-buffer (point pane)) + (update-syntax buffer (syntax buffer)) + (clear-modify buffer) + buffer))))))) (defmethod find-file (filepath (application-frame climacs)) (find-file-impl filepath nil)) --- /project/climacs/cvsroot/climacs/climacs.asd 2006/09/06 17:42:08 1.53 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/09/06 20:07:21 1.54 @@ -97,13 +97,14 @@ (:file "io" :depends-on ("packages" "gui")) (:file "core" :depends-on ("gui")) (:file "rectangle" :depends-on ("core")) + (: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 "file-commands" :depends-on ("gui" "core")) - (:file "misc-commands" :depends-on ("gui" "core" "rectangle")) + (:file "misc-commands" :depends-on ("gui" "core" "rectangle" "groups")) (:file "search-commands" :depends-on ("gui" "core")) (:file "window-commands" :depends-on ("gui" "core")) (:file "unicode-commands" :depends-on ("gui" "core")) --- /project/climacs/cvsroot/climacs/groups.lisp 2006/09/06 20:07:22 NONE +++ /project/climacs/cvsroot/climacs/groups.lisp 2006/09/06 20:07:22 1.1 ;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*- ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas at 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. ;;; Implementation of a groups concept. (in-package :climacs-core) (defvar *persistent-groups* (make-hash-table :test #'equal) "A hash table of groups that are persistent across invocations of the Climacs editor. Typically, these do not designate concrete pathnames, but contain more abstract designations such as \"all files in the current directory\".") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; File/Buffer group classes. (defclass group (name-mixin) ()) (defclass group-element (group) ((%element :initarg :element :initform nil :reader element)) (:documentation "Group class denoting a single element")) (defclass standard-group (group) ((%elements :initarg :elements :initform nil :reader elements)) (:documentation "Group class denoting a sequence of elements.")) (defclass current-buffer-group (group) () (:documentation "Group class denoting the currently active buffer.")) (defclass synonym-group (group) ((%other-name :initarg :other-name :initform (error "The name of another buffer must be provided") :reader other-name)) (:documentation "Group class that forwards all methods to a group with a specific name.")) (defclass custom-group (group) ((%list-pathnames-lambda :initarg :pathname-lister :initform (error "A custom group must have code for retrieving a list of pathnames") :reader pathname-lister) (%select-group-lambda :initarg :select-response :initform #'(lambda (&rest a) (declare (ignore a))) :reader select-response) (%value-plist :initform nil :accessor value-plist)) (:documentation "A group that will call a provided function when it is selected or asked for pathnames.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The group protocol. (defgeneric group-buffers (group) (:documentation "Get a list of buffers in `group'. Only already existing buffers will be returned, use `ensure-group-buffers' if you want all buffers defined by the group.")) (defgeneric ensure-group-buffers (group) (:documentation "For each pathname in `group' that does not have a corresponding buffer, open a buffer for that pathname.")) (defgeneric select-group (group) (:documentation "Tell the group object `group' that the user has selected it. This method is responsible for setting the active group. If `group' needs additional information, it should query the user when this method is invoked. The standard method should be sufficient for most group classes.") (:method ((group group)) ;; Use a synonym group so that changes to the group of this name ;; will be reflected in the active group. (setf (active-group *application-frame*) (make-synonym-group group)))) (defgeneric display-group-contents (group stream) (:documentation "Display the contents of `group' to `stream'. Basically, this should describe which buffers or files would be affected by group-aware commands if `group' was the active group. There is no standard format for the output, but it is intended for displaying to the user.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Protocol implementation. ;; Display helper functions. (defun normalise-group-element (element) "Turn `element' into either a pathname, an existing buffer or NIL. If a pathname is returned, it is assumed to be safe to find the file with that name." (typecase element (climacs-buffer (find element (buffers *application-frame*))) ((or pathname string) (or (find-buffer-with-pathname (pathname element)) (when (findablep element) element))) (group-element (normalise-group-element (element element))))) (defun display-group-element (element stream) (let ((norm-element (normalise-group-element element))) (typecase norm-element (climacs-buffer (present norm-element 'buffer stream)) ((or pathname string) (present norm-element 'pathname stream))))) ;; Singular group elements. (defmethod group-buffers ((group group-element)) (let ((element (element group))) (cond ((and (typep element 'climacs-buffer) (find element (buffers *application-frame*))) (list element)) ((or (pathnamep element) (stringp element)) (let ((buffer (find-buffer-with-pathname (pathname element)))) (when buffer (list buffer)))) (t '())))) (defmethod ensure-group-buffers ((group group-element)) (typecase (element group) (climacs-buffer (unless (find (element group) (buffers *application-frame*)) (ensure-open-file (pathname (filepath (element group)))))) (pathname (ensure-open-file (element group))) (string (ensure-open-file (pathname (element group)))))) (defmethod display-group-contents ((group group-element) (stream extended-output-stream)) (display-group-element (element group) stream)) ;; Standard sequence groups. (defmethod group-buffers ((group standard-group)) (apply #'append (mapcar #'group-buffers (elements group)))) (defmethod ensure-group-buffers ((group standard-group)) (mapcar #'ensure-group-buffers (elements group))) (defmethod display-group-contents ((group standard-group) (stream extended-output-stream)) (present (remove-if #'null (mapcar #'normalise-group-element (elements group))) '(sequence (or pathname buffer)) :stream stream)) ;; The current buffer group (default). (defmethod group-buffers ((group current-buffer-group)) (list (current-buffer))) (defmethod ensure-group-buffers ((group current-buffer-group)) nil) (defmethod display-group-contents ((group current-buffer-group) (stream extended-output-stream)) (display-group-element (current-buffer) stream)) ;; Custom groups. (defmethod group-buffers ((group custom-group)) (remove-if #'null (mapcar #'find-buffer-with-pathname (funcall (pathname-lister group) group)))) (defmethod ensure-group-buffers ((group custom-group)) (mapcar #'ensure-open-file (funcall (pathname-lister group) group))) (defmethod select-group ((group custom-group)) (funcall (select-response group) group) (setf (active-group *application-frame*) group)) (defmethod display-group-contents ((group custom-group) (stream extended-output-stream)) (present (remove-if #'null (mapcar #'normalise-group-element (funcall (pathname-lister group) group))) '(sequence (or pathname buffer)) :stream stream)) ;; Synonym groups. (define-condition group-not-found (simple-error) ((%group-name :reader group-name :initarg :group-name :initform (error "A name for the group must be provided"))) (:report (lambda (condition stream) (format stream "Group named ~a not found" (group-name condition)))) (:documentation "This condition is signaled whenever a synonym group is unable to find the group that it is supposed to forward method invocations to.")) (defmethod group-buffers ((group synonym-group)) (if (get-group (other-name group)) (group-buffers (get-group (other-name group))) (error 'group-not-found :group-name (other-name group)))) (defmethod ensure-group-buffers ((group synonym-group)) (if (get-group (other-name group)) (ensure-group-buffers (get-group (other-name group))) (error 'group-not-found :group-name (other-name group)))) (defmethod select-group ((group synonym-group)) (if (get-group (other-name group)) (select-group (get-group (other-name group))) (error 'group-not-found :group-name (other-name group)))) (defmethod display-group-contents ((group synonym-group) stream) (if (get-group (other-name group)) (display-group-contents (get-group (other-name group)) stream) (error 'group-not-found :group-name (other-name group)))) ;; Util stuff. (defun make-synonym-group (group) "Create and return a synonym group that refers to `group'. All group protocol-specified methods called on the synonym group will be forwarded to a group with the same name as `group'." (make-instance 'synonym-group :other-name (name group) :name (name group))) (defun make-group-element (object) "Make a `group-element' object containg `object' as element." (make-instance 'group-element :element object)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Interface (defun add-group (name elements) "Define a group called `name' (a string) containing the elements `elements', which must be a list of pathnames and/or buffers, and add it to the list of defined groups." (setf (gethash name (groups *application-frame*)) (make-instance 'standard-group :name name :elements (mapcar #'make-group-element elements)))) (defun get-group (name) "Return the group with the name `name'." (or (gethash name (groups *application-frame*)) (gethash name *persistent-groups*))) (defun get-active-group () "Return the currently active group." (or (active-group *application-frame*) (deselect-group))) (defun deselect-group () "Deselect the currently active group." (setf (active-group *application-frame*) (make-instance 'current-buffer-group :name "none"))) (defmacro with-group-buffers ((buffers group &key keep) &body body) "Make sure that all files designated by `group' are open in buffers during the evaluation of `body'. If `keep' is NIL, all buffers created by this macro will be saved and killed after `body' has run. Also, `buffers' will be bound to a list of the buffers containing the files designated by `group' while `body' is run." (let ((buffers-before-sym (gensym)) (buffers-after-sym (gensym)) (buffer-diff-sym (gensym)) (group-val-sym (gensym))) `(let ((,buffers-before-sym (buffers *application-frame*)) (,group-val-sym ,group)) (ensure-group-buffers ,group-val-sym) (let* ((,buffers-after-sym (buffers *application-frame*)) (,buffer-diff-sym (set-difference ,buffers-after-sym ,buffers-before-sym)) (,buffers (group-buffers ,group-val-sym))) (unwind-protect (progn , at body) (unless ,keep (loop for buffer in ,buffer-diff-sym do (save-buffer buffer *application-frame*) do (kill-buffer buffer)))))))) (defmacro define-group (name (group-arg &rest args) &body body) "Define a persistent group named `name'. `Body' should return a list of pathnames and will be used to calculate which files are designated by the group. `Args' should be two-element lists, with the first element bound to the result of evaluating the second element. The second element will be evaluated when the group is selected to be the active group by the user." (let ((name-val-sym (gensym)) (group-val-sym (gensym))) `(let ((,name-val-sym ,name)) (assert (stringp ,name-val-sym)) (setf (gethash ,name-val-sym *persistent-groups*) (make-instance 'custom-group :name ,name-val-sym :pathname-lister #'(lambda (,group-val-sym) (destructuring-bind (&key ,@(mapcar #'(lambda (arg) `((,arg ,arg))) (mapcar #'first args))) (value-plist ,group-val-sym) (let ((,group-arg ,group-val-sym)) , at body))) :select-response #'(lambda (group) (declare (ignorable group)) ,@(loop for (name form) in args collect `(setf (getf (value-plist group) ',name) ,form)))))))) (define-group "Current Directory Files" (group) (declare (ignore group)) (directory (make-pathname :directory (pathname-directory (filepath (current-buffer))) :name :wild :type :wild))) (define-group "Directory Files" (group (directory (accept 'pathname :prompt "Directory" :default (directory-of-buffer (current-buffer)) :insert-default t))) (declare (ignore group)) (directory (make-pathname :directory (pathname-directory directory) :name :wild :type :wild))) (define-group "Directory Lisp Files" (group (directory (accept 'pathname :prompt "Directory" :default (directory-of-buffer (current-buffer)) :insert-default t))) (declare (ignore group)) (directory (make-pathname :directory (pathname-directory directory) :name :wild :type "lisp"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; CLIM interface stuff. (define-presentation-method accept ((type group) stream view &key (default nil defaultp) (default-type type)) (multiple-value-bind (object success string) (complete-input stream (lambda (so-far action) (complete-from-possibilities so-far (append (loop for key being the hash-keys of (groups *application-frame*) collecting key) (loop for key being the hash-keys of *persistent-groups* collecting key)) '(#\Space) :action action :name-key #'identity :value-key #'identity)) :partial-completers '(#\Space) :allow-any-input nil) (cond (success (values (get-group object) type)) ((and (zerop (length string)) defaultp) (values default default-type)) (t (values string 'string))))) (define-presentation-method present (object (type group) stream view &key) (let ((name (name object))) (princ name stream))) (define-presentation-method present ((object synonym-group) (type group) stream view &key) (if (get-group (other-name object)) (present (get-group (other-name object)) type :stream stream :view view) (error 'group-not-found :group-name (other-name object)))) From thenriksen at common-lisp.net Fri Sep 8 18:08:03 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 8 Sep 2006 14:08:03 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060908180803.4B11B1006@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv26054 Modified Files: packages.lisp esa.asd esa-io.lisp esa-buffer.lisp Log Message: Changed some generic functions to be nongeneric trampolines calling generic functions with *application-frame* as the argument. This is because 99% of the time, these functions will always be called with *application-frame* as the frame argument, so there's no need to make it explicit in every call. --- /project/climacs/cvsroot/esa/packages.lisp 2006/09/03 21:22:05 1.7 +++ /project/climacs/cvsroot/esa/packages.lisp 2006/09/08 18:08:03 1.8 @@ -17,18 +17,21 @@ (defpackage :esa-buffer (:use :clim-lisp :clim :esa) - (:export #:make-buffer-from-stream #:save-buffer-to-stream + (:export #:frame-make-buffer-from-stream #:make-buffer-from-stream + #:frame-save-buffer-to-stream #:save-buffer-to-stream #:filepath #:name #:needs-saving #:file-write-time #:file-saved-p #:esa-buffer-mixin - #:make-new-buffer + #:frame-make-new-buffer #:make-new-buffer #:read-only-p)) (defpackage :esa-io (:use :clim-lisp :clim :esa :esa-buffer) (:export #:buffers #:frame-current-buffer #:current-buffer - #:find-file #:find-file-read-only - #:set-visited-filename - #:save-buffer #:write-buffer + #:frame-find-file #:find-file + #:frame-find-file-read-only #:find-file-read-only + #:frame-set-visited-filename #:set-visited-filename + #:frame-save-buffer #:save-buffer + #:frame-write-buffer #:write-buffer #:esa-io-table)) #-mcclim --- /project/climacs/cvsroot/esa/esa.asd 2006/05/10 09:52:05 1.5 +++ /project/climacs/cvsroot/esa/esa.asd 2006/09/08 18:08:03 1.6 @@ -4,5 +4,5 @@ (:file "colors" :depends-on ("packages")) (:file "esa" :depends-on ("colors" "packages")) (:file "esa-buffer" :depends-on ("packages" "esa")) - (:file "esa-io" :depends-on ("packages" "esa")) + (:file "esa-io" :depends-on ("packages" "esa" "esa-buffer")) (:file "esa-command-parser" :depends-on ("packages" "esa")))) --- /project/climacs/cvsroot/esa/esa-io.lisp 2006/09/03 21:22:05 1.5 +++ /project/climacs/cvsroot/esa/esa-io.lisp 2006/09/08 18:08:03 1.6 @@ -31,19 +31,29 @@ calls `frame-current-buffer' with `frame' as argument." (frame-current-buffer frame)) -(defgeneric find-file (file-path application-frame)) -(defgeneric find-file-read-only (file-path application-frame)) -(defgeneric set-visited-filename (filepath buffer application-frame)) -(defgeneric save-buffer (buffer application-frame)) -(defgeneric write-buffer (buffer filepath application-frame)) +(defgeneric frame-find-file (application-frame file-path) + (:documentation "If a buffer with the file-path already exists, +return it, else if a file with the right name exists, return a +fresh buffer created from the file, else return a new empty +buffer having the associated file name.")) +(defgeneric frame-find-file-read-only (application-frame file-path)) +(defgeneric frame-set-visited-file-name (application-frame filepath buffer)) +(defgeneric frame-save-buffer (application-frame buffer)) +(defgeneric frame-write-buffer (application-frame filepath buffer)) + +(defun find-file (file-path) + (frame-find-file *application-frame* file-path)) +(defun find-file-read-only (file-path) + (frame-find-file-read-only *application-frame* file-path)) +(defun set-visited-file-name (filepath buffer) + (frame-set-visited-file-name *application-frame* filepath buffer)) +(defun save-buffer (buffer) + (frame-save-buffer *application-frame* buffer)) +(defun write-buffer (filepath buffer) + (frame-write-buffer *application-frame* filepath buffer)) (make-command-table 'esa-io-table :errorp nil) -(defgeneric find-file (file-path application-frame) - (:documentation "if a buffer with the file-path already exists, return it, -else if a file with the right name exists, return a fresh buffer created from -the file, else return a new empty buffer having the associated file name.")) - (defun filename-completer (so-far mode) (flet ((remove-trail (s) (subseq s 0 (let ((pos (position #\/ s :from-end t))) @@ -143,7 +153,7 @@ (concatenate 'string (pathname-name pathname) "." (pathname-type pathname)))) -(defmethod find-file (filepath application-frame) +(defmethod frame-find-file (application-frame filepath) (cond ((null filepath) (display-message "No file name given.") (beep)) @@ -155,8 +165,8 @@ :key #'filepath :test #'equal) (let ((buffer (if (probe-file filepath) (with-open-file (stream filepath :direction :input) - (make-buffer-from-stream stream *application-frame*)) - (make-new-buffer *application-frame*)))) + (make-buffer-from-stream stream)) + (make-new-buffer)))) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath) (needs-saving buffer) nil) @@ -183,12 +193,12 @@ If a buffer is already visiting that file, switch to that buffer. Does not create a file if the filename given does not name an existing file." - (find-file filepath *application-frame*)) + (find-file filepath)) (set-key `(com-find-file ,*unsupplied-argument-marker*) 'esa-io-table '((#\x :control) (#\f :control))) -(defmethod find-file-read-only (filepath application-frame) +(defmethod frame-find-file-read-only (application-frame filepath) (cond ((null filepath) (display-message "No file name given.") (beep)) @@ -200,7 +210,7 @@ :key #'filepath :test #'equal) (if (probe-file filepath) (with-open-file (stream filepath :direction :input) - (let ((buffer (make-buffer-from-stream stream *application-frame*))) + (let ((buffer (make-buffer-from-stream stream))) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath) (read-only-p buffer) t @@ -221,7 +231,7 @@ If a buffer is already visiting that file, switch to that buffer. If the filename given does not name an existing file, signal an error." - (find-file-read-only filepath *application-frame*)) + (find-file-read-only filepath)) (set-key `(com-find-file-read-only ,*unsupplied-argument-marker*) 'esa-io-table '((#\x :control) (#\r :control))) @@ -236,9 +246,9 @@ (set-key 'com-read-only 'esa-io-table '((#\x :control) (#\q :control))) -(defmethod set-visited-file-name (filename buffer application-frame) - (setf (filepath buffer) filename - (name buffer) (filepath-filename filename) +(defmethod frame-set-visited-file-name (application-frame filepath buffer) + (setf (filepath buffer) filepath + (name buffer) (filepath-filename filepath) (needs-saving buffer) t)) (define-command (com-set-visited-file-name :name t :command-table esa-io-table) @@ -251,7 +261,7 @@ "Prompt for a new filename for the current buffer. The next time the buffer is saved it will be saved to a file with that filename." - (set-visited-file-name filename (current-buffer) *application-frame*)) + (set-visited-file-name filename (current-buffer))) (defun extract-version-number (pathname) "Extracts the emacs-style version-number from a pathname." @@ -288,7 +298,7 @@ nil)) t))) -(defmethod save-buffer (buffer application-frame) +(defmethod frame-save-buffer (application-frame buffer) (let ((filepath (or (filepath buffer) (accept 'pathname :prompt "Save Buffer to File")))) (cond @@ -297,7 +307,7 @@ (beep)) (t (unless (check-file-times buffer filepath "Overwrite" "written") - (return-from save-buffer)) + (return-from frame-save-buffer)) (when (and (probe-file filepath) (not (file-saved-p buffer))) (let ((backup-name (pathname-name filepath)) (backup-type (format nil "~A~~~D~~" @@ -320,12 +330,12 @@ (let ((buffer (current-buffer))) (if (or (null (filepath buffer)) (needs-saving buffer)) - (save-buffer buffer *application-frame*) + (save-buffer buffer) (display-message "No changes need to be saved from ~a" (name buffer))))) (set-key 'com-save-buffer 'esa-io-table '((#\x :control) (#\s :control))) -(defmethod write-buffer (buffer filepath application-frame) +(defmethod frame-write-buffer (application-frame filepath buffer) (cond ((directory-pathname-p filepath) (display-message "~A is a directory name." filepath)) @@ -344,7 +354,7 @@ "Prompt for a filename and write the current buffer to it. Changes the file visted by the buffer to the given file." (let ((buffer (current-buffer))) - (write-buffer buffer filepath *application-frame*))) + (write-buffer buffer filepath))) (set-key `(com-write-buffer ,*unsupplied-argument-marker*) 'esa-io-table '((#\x :control) (#\w :control))) --- /project/climacs/cvsroot/esa/esa-buffer.lisp 2006/08/20 10:08:23 1.2 +++ /project/climacs/cvsroot/esa/esa-buffer.lisp 2006/09/08 18:08:03 1.3 @@ -20,17 +20,31 @@ (in-package :esa-buffer) -(defgeneric make-buffer-from-stream (stream application-frame) +(defgeneric frame-make-buffer-from-stream (application-frame stream) (:documentation "Create a fresh buffer by reading the external representation from STREAM")) -(defgeneric make-new-buffer (application-frame) - (:documentation "Create a empty buffer for the application frame")) +(defun make-buffer-from-stream (stream) + "Create a fresh buffer by reading the external representation +from STREAM" + (frame-make-buffer-from-stream *application-frame* stream)) + +(defgeneric frame-make-new-buffer (application-frame &key &allow-other-keys) + (:documentation "Create a empty buffer for the application frame.")) + +(defun make-new-buffer (&key &allow-other-keys) + "Create a empty buffer for the current frame." + (frame-make-new-buffer *application-frame*)) -(defgeneric save-buffer-to-stream (buffer stream) +(defgeneric frame-save-buffer-to-stream (application-frame buffer stream) (:documentation "Save the entire BUFFER to STREAM in the appropriate external representation")) +(defun save-buffer-to-stream (buffer stream) + "Save the entire BUFFER to STREAM in the appropriate external +representation" + (frame-save-buffer-to-stream *application-frame* buffer stream)) + (defclass esa-buffer-mixin () ((%filepath :initform nil :accessor filepath) (%name :initarg :name :initform "*scratch*" :accessor name) From thenriksen at common-lisp.net Fri Sep 8 18:12:03 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 8 Sep 2006 14:12:03 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060908181203.9E88779000@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv26340 Modified Files: lisp-syntax-swine.lisp io.lisp groups.lisp core.lisp Log Message: Update to work with recent ESA changes. --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/08/30 19:32:23 1.3 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/08 18:12:03 1.4 @@ -1016,7 +1016,7 @@ (namestring path))))))) (if buffer (switch-to-buffer buffer) - (find-file (file-name location) *application-frame*)) + (find-file (file-name location))) (goto-position (point (current-window)) (char-position (source-position location))))) @@ -1098,7 +1098,7 @@ (t (when (and (needs-saving buffer) (accept 'boolean :prompt (format nil "Save buffer ~A ?" (name buffer)))) - (save-buffer buffer *application-frame*)) + (save-buffer buffer)) (let ((*read-base* (base (syntax buffer)))) (multiple-value-bind (result notes) (compile-file-for-climacs (get-usable-image (syntax buffer)) @@ -1173,7 +1173,7 @@ Returns NIL if an arglist cannot be displayed." (multiple-value-bind (arglist emphasized-symbols highlighted-symbols) (analyze-arglist - (arglist-for-form (syntax (current-buffer *application-frame*)) operator arguments) + (arglist-for-form (syntax (current-buffer)) operator arguments) current-arg-indices preceding-arg arguments) @@ -1230,7 +1230,7 @@ (defun edit-definition (symbol &optional type) (let ((all-definitions (find-definitions-for-climacs - (get-usable-image (syntax (current-buffer *application-frame*))) + (get-usable-image (syntax (current-buffer))) symbol))) (let ((definitions (if (not type) all-definitions --- /project/climacs/cvsroot/climacs/io.lisp 2006/09/02 11:41:41 1.6 +++ /project/climacs/cvsroot/climacs/io.lisp 2006/09/08 18:12:03 1.7 @@ -24,7 +24,7 @@ (in-package :climacs-core) -(defmethod save-buffer-to-stream ((buffer climacs-buffer) stream) +(defmethod frame-save-buffer-to-stream ((application-frame climacs) (buffer climacs-buffer) stream) (let ((seq (buffer-sequence buffer 0 (size buffer)))) (write-sequence seq stream))) @@ -37,7 +37,7 @@ seq (subseq seq 0 count))))) -(defmethod make-buffer-from-stream (stream (application-frame climacs)) +(defmethod frame-make-buffer-from-stream ((application-frame climacs) stream) (let* ((buffer (make-new-buffer application-frame))) (input-from-stream stream buffer 0) buffer)) --- /project/climacs/cvsroot/climacs/groups.lisp 2006/09/06 20:07:21 1.1 +++ /project/climacs/cvsroot/climacs/groups.lisp 2006/09/08 18:12:03 1.2 @@ -287,7 +287,7 @@ (unwind-protect (progn , at body) (unless ,keep (loop for buffer in ,buffer-diff-sym - do (save-buffer buffer *application-frame*) + do (save-buffer buffer) do (kill-buffer buffer)))))))) (defmacro define-group (name (group-arg &rest args) &body body) --- /project/climacs/cvsroot/climacs/core.lisp 2006/09/06 20:07:21 1.8 +++ /project/climacs/cvsroot/climacs/core.lisp 2006/09/08 18:12:03 1.9 @@ -334,16 +334,12 @@ ;;; ;;; Buffer handling -(defmethod make-new-buffer ((application-frame climacs)) - (let ((buffer (make-instance 'climacs-buffer))) +(defmethod frame-make-new-buffer ((application-frame climacs) + &key (name "*scratch*")) + (let ((buffer (make-instance 'climacs-buffer :name name))) (push buffer (buffers application-frame)) buffer)) -(defun make-new-named-buffer (&optional name) - (let ((buffer (make-new-buffer *application-frame*))) - (when name (setf (name buffer) name)) - buffer)) - (defgeneric erase-buffer (buffer)) (defmethod erase-buffer ((buffer string)) @@ -401,7 +397,7 @@ (let ((buffer (find name (buffers *application-frame*) :key #'name :test #'string=))) (switch-to-buffer (or buffer - (make-new-named-buffer name))))) + (make-new-buffer :name name))))) ;;placeholder (defmethod switch-to-buffer ((symbol (eql 'nil))) @@ -424,11 +420,11 @@ (error () (progn (beep) (display-message "Invalid answer") (return-from kill-buffer nil))))) - (save-buffer buffer *application-frame*)) + (save-buffer buffer)) (setf buffers (remove buffer buffers)) ;; Always need one buffer. (when (null buffers) - (make-new-named-buffer "*scratch*")) + (make-new-buffer :name "*scratch*")) (setf (buffer (current-window)) (car buffers)) (full-redisplay (current-window)) (buffer (current-window)))) @@ -621,7 +617,7 @@ file if necessary." (when (and (findablep pathname) (not (find-buffer-with-pathname pathname))) - (find-file pathname *application-frame*))) + (find-file pathname))) (defun find-file-impl (filepath &optional readonlyp) (cond ((null filepath) @@ -642,8 +638,8 @@ (return-from find-file-impl nil))) (let ((buffer (if (probe-file filepath) (with-open-file (stream filepath :direction :input) - (make-buffer-from-stream stream *application-frame*)) - (make-new-buffer *application-frame*))) + (make-buffer-from-stream stream)) + (make-new-buffer))) (pane (current-window))) (setf (offset (point (buffer pane))) (offset (point pane)) (buffer (current-window)) buffer @@ -659,10 +655,10 @@ (clear-modify buffer) buffer))))))) -(defmethod find-file (filepath (application-frame climacs)) +(defmethod frame-find-file ((application-frame climacs) filepath) (find-file-impl filepath nil)) -(defmethod find-file-read-only (filepath (application-frame climacs)) +(defmethod frame-find-file-read-only ((application-frame climacs) filepath) (find-file-impl filepath t)) (defun directory-of-buffer (buffer) @@ -675,7 +671,7 @@ (or (filepath buffer) (user-homedir-pathname))))) -(defmethod set-visited-filename (filepath buffer (application-frame climacs)) +(defmethod frame-set-visited-filename ((application-frame climacs) filepath buffer) (setf (filepath buffer) filepath (file-saved-p buffer) nil (file-write-time buffer) nil @@ -705,7 +701,7 @@ (error () (progn (beep) (display-message "Invalid answer") (return-from frame-exit nil))))) - do (save-buffer buffer frame)) + do (save-buffer buffer)) (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer))) (buffers frame)) (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?") From thenriksen at common-lisp.net Sat Sep 9 18:21:03 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 9 Sep 2006 14:21:03 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060909182103.17C955B056@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv29495 Modified Files: io.lisp Log Message: Fix related to ESA changes. --- /project/climacs/cvsroot/climacs/io.lisp 2006/09/08 18:12:03 1.7 +++ /project/climacs/cvsroot/climacs/io.lisp 2006/09/09 18:21:02 1.8 @@ -38,6 +38,6 @@ (subseq seq 0 count))))) (defmethod frame-make-buffer-from-stream ((application-frame climacs) stream) - (let* ((buffer (make-new-buffer application-frame))) + (let* ((buffer (make-new-buffer))) (input-from-stream stream buffer 0) buffer)) From thenriksen at common-lisp.net Sat Sep 9 18:21:40 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 9 Sep 2006 14:21:40 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060909182140.953765B066@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv29556 Modified Files: rectangle.lisp Log Message: Fix regarding killing of rectangles across lines that are shorter than the width of the rectangle. --- /project/climacs/cvsroot/climacs/rectangle.lisp 2006/09/04 09:00:30 1.1 +++ /project/climacs/cvsroot/climacs/rectangle.lisp 2006/09/09 18:21:40 1.2 @@ -76,7 +76,9 @@ (let ((str (concatenate 'string (buffer-substring (buffer mark) (offset start-mark) (offset end-mark)) - (make-string (- endcol (column-number end-mark)) :initial-element #\Space)))) + (make-string (- (- endcol startcol) + (- (column-number end-mark) (column-number start-mark))) + :initial-element #\Space)))) (delete-range start-mark (- (offset end-mark) (offset start-mark))) str))) From thenriksen at common-lisp.net Mon Sep 11 08:55:21 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 11 Sep 2006 04:55:21 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060911085521.AB05A2D01F@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv11152 Modified Files: lisp-syntax.lisp lisp-syntax-swine.lisp Log Message: Fixed some bugs related to evil argument lists (SBCL `make-string') and made applicable-form-finding even more intelligent (again). --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/02 21:43:56 1.112 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/11 08:55:21 1.113 @@ -33,6 +33,11 @@ (funcall fn obj) obj)) +(defun fully-unlisted (obj &optional (fn #'first)) + (if (listp obj) + (fully-unlisted (funcall fn obj)) + obj)) + (defun listed (obj) (if (listp obj) obj --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/08 18:12:03 1.4 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/11 08:55:21 1.5 @@ -118,7 +118,7 @@ (unlisted (find (symbol-name keyword) (get-args '&key) :key #'(lambda (arg) - (symbol-name (unlisted arg))) + (symbol-name (fully-unlisted arg))) :test #'string=)))) ;; We have to find the associated ;; symbol in the argument list... ugly. @@ -166,7 +166,7 @@ (get-args '&key) :test #'string= :key #'(lambda (arg) - (symbol-name (unlisted arg)))))) + (symbol-name (fully-unlisted arg)))))) ;; We are in the &body, &rest or &key arguments. (values ;; Only emphasize the &key @@ -369,7 +369,7 @@ (worker (parent operand-form))))))))) (nreverse (worker operand-form t))))) -(defun find-operand-info (mark-or-offset syntax operator-form) +(defun find-operand-info (syntax mark-or-offset operator-form) "Returns two values: The operand preceding `mark-or-offset' and the path from `operator-form' to the operand." (as-offsets ((offset mark-or-offset)) @@ -444,31 +444,62 @@ (indices-match-arglist arg (rest arg-indices))) (t t)))) -(defun direct-arg-p (form syntax) - "Check whether `form' is a direct argument to one of its - parents." - (labels ((recurse (parent) - (let ((operator (form-operator - parent - syntax))) - (or (and - ;; An operator is not an argument to itself... - (not (= (start-offset form) - (start-offset (first-form (children parent))))) - (valid-operator-p operator) - (indices-match-arglist - (arglist (image syntax) - operator) - (second - (multiple-value-list - (find-operand-info - (start-offset form) - syntax - parent))))) - (when (parent parent) - (recurse (parent parent))))))) - (when (parent form) - (recurse (parent form))))) +(defun direct-arg-p (syntax operator-form arg-form) + "Is `arg-form' a direct argument to `operator-form'? A \"direct +argument\" is defined as an argument that would be directly bound +to a symbol when evaluating the operators body, or as an argument +that would be a direct component of a &body or &rest argument." + (let ((operator (token-to-object syntax operator-form))) + (and + ;; An operator is not an argument to itself. + (not (eq arg-form + (first-form (children (parent operator-form))))) + ;; An operator must be valid. + (valid-operator-p operator) + ;; The argument must match the operators argument list. + (indices-match-arglist + (arglist (image syntax) + operator) + (nth-value 1 (find-operand-info + syntax + (start-offset arg-form) + (parent operator-form))))))) + +(defun find-direct-operator (syntax arg-form) + "Check whether `arg-form' is a direct argument to one of its +parents. If it is, return the form with the operator that +`arg-form' is a direct argument to. If not, return NIL." + (labels ((recurse (form) + ;; Check whether `arg-form' is a direct argument to + ;; the operator of `form'. + (when (parent form) + (if (direct-arg-p syntax (first-form (children form)) arg-form) + form + (recurse (parent form)))))) + (recurse (parent arg-form)))) + +(defun find-applicable-form (syntax arg-form) + "Find the enclosing form that has `arg-form' as a valid +argument. Return NIL if none can be found." + ;; The algorithm for finding the applicable form: + ;; + ;; From `arg-form', we wander up the tree looking enclosing forms, + ;; until we find a a form with an operator, the form-operator, that + ;; has `arg-form' as a direct argument (this is checked by comparing + ;; argument indices for `arg-form', relative to form-operator, with + ;; the arglist ofform-operator). However, if form-operator itself is + ;; a direct argument to one of its parents, we ignore it (unless + ;; form-operators form-operator is itself a direct argument, + ;; etc). This is so we can properly handle nested/destructuring + ;; argument lists such as those found in macros. + (labels ((recurse (candidate-form) + (when (parent candidate-form) + (if (and (direct-arg-p syntax (first-form (children candidate-form)) + arg-form) + (not (find-applicable-form syntax (first-form (children candidate-form))))) + candidate-form + (recurse (parent candidate-form)))))) + (recurse (parent arg-form)))) (defun relevant-keywords (arglist arg-indices) "Return a list of the keyword arguments that it would make @@ -526,7 +557,8 @@ :test #'(lambda (a b) (string-equal a b :start1 1)) - :key #'symbol-name)) + :key #'(lambda (s) + (symbol-name (fully-unlisted s))))) (mapcar #'string-downcase completions)))) relevant-completions)) completions)))) @@ -719,31 +751,12 @@ ;; Find a form with a valid (fboundp) operator. (let ((immediate-form (preceding-form ,mark-value-sym ,syntax-value-sym))) - ;; Recurse upwards until we find a form with a valid - ;; operator. This could be improved a lot, as we could - ;; inspect the lambda list of the found operator and - ;; check if the position of mark makes sense with - ;; regard to the structure of the lambda list. If we - ;; cannot find a form with a valid operator, just - ;; return the form `mark' is in. (unless (null immediate-form) - (labels ((recurse (form) - (unless (null (parent form)) - (or (unless (eq (first-form (children (parent form))) - form) - (recurse (parent form))) - (and (valid-operator-p (form-operator - form - ,syntax-value-sym)) - (indices-match-arglist - (arglist-for-form - ,syntax-value-sym - (form-operator form ,syntax-value-sym) - (form-operands form ,syntax-value-sym)) - (nth-value 1 (find-operand-info ,mark-value-sym ,syntax-value-sym form))) - (not (direct-arg-p form ,syntax-value-sym)) - form))))) - (or (recurse (parent immediate-form)) + (or (find-applicable-form ,syntax-value-sym immediate-form) + ;; If nothing else can be found, and `arg-form' + ;; is the operator of its enclosing form, we use + ;; the enclosing form. + (when (eq (first-form (children (parent immediate-form))) immediate-form) (parent immediate-form)))))) ;; If we cannot find a form, there's no point in looking ;; up any of this stuff. @@ -752,7 +765,7 @@ (declare (ignorable ,mark-value-sym ,syntax-value-sym ,form-sym ,operator-sym ,operands-sym)) (multiple-value-bind (,preceding-operand-sym ,operand-indices-sym) - (when ,form-sym (find-operand-info ,mark-value-sym ,syntax-value-sym ,form-sym)) + (when ,form-sym (find-operand-info ,syntax-value-sym ,mark-value-sym ,form-sym)) (declare (ignorable ,preceding-operand-sym ,operand-indices-sym)) , at body)))) From thenriksen at common-lisp.net Mon Sep 11 20:13:33 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 11 Sep 2006 16:13:33 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060911201333.4AECC4714B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12218 Modified Files: syntax.lisp rectangle.lisp pane.lisp packages.lisp lisp-syntax.lisp lisp-syntax-swine.lisp groups.lisp fundamental-syntax.lisp climacs.asd base.lisp Added Files: utils.lisp Log Message: Added utils.lisp file and CLIMACS-UTILS package so it's no longer necessary to hand-roll `with-gensyms', `once-only' and other helpful macros. --- /project/climacs/cvsroot/climacs/syntax.lisp 2006/09/02 21:43:56 1.71 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/09/11 20:13:32 1.72 @@ -207,13 +207,13 @@ of the option." ;; The name is converted to a keyword symbol which is used for all ;; further identification. - (let ((name-symbol (gensym)) - (symbol (intern (string-upcase option-name) - (find-package :keyword)))) - `(defmethod eval-option ((,syntax-symbol ,syntax) - (,name-symbol (eql ,symbol)) - ,value-symbol) - , at body))) + (with-gensyms (name) + (let ((symbol (intern (string-upcase option-name) + (find-package :keyword)))) + `(defmethod eval-option ((,syntax-symbol ,syntax) + (,name (eql ,symbol)) + ,value-symbol) + , at body)))) (defgeneric current-attributes-for-syntax (syntax) (:method-combination append) --- /project/climacs/cvsroot/climacs/rectangle.lisp 2006/09/09 18:21:40 1.2 +++ /project/climacs/cvsroot/climacs/rectangle.lisp 2006/09/11 20:13:32 1.3 @@ -54,18 +54,16 @@ columns `startcol' and `endcol'. If `force-start' or `force-end' is non-NIL, the line will be padded with space characters in order to put `start-mark' or `end-mark' at their specified columns respectively." - (let ((mark-val-sym (gensym)) - (startcol-val-sym (gensym)) - (endcol-val-sym (gensym))) + (once-only (mark startcol endcol) `(progn - (let ((,mark-val-sym ,mark) - (,startcol-val-sym ,startcol) - (,endcol-val-sym ,endcol)) - (move-to-column ,mark-val-sym ,startcol-val-sym ,force-start) - (let ((,start-mark (clone-mark ,mark-val-sym))) - (let ((,end-mark (clone-mark ,mark-val-sym))) - (move-to-column ,end-mark ,endcol-val-sym ,force-end) - , at body)))))) + (let ((,mark ,mark) + (,startcol ,startcol) + (,endcol ,endcol)) + (move-to-column ,mark ,startcol ,force-start) + (let ((,start-mark (clone-mark ,mark))) + (let ((,end-mark (clone-mark ,mark))) + (move-to-column ,end-mark ,endcol ,force-end) + , at body)))))) (defun extract-and-delete-rectangle-line (mark startcol endcol) "For the line that `mark' is in, delete and return the string --- /project/climacs/cvsroot/climacs/pane.lisp 2006/09/02 21:43:56 1.52 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/09/11 20:13:32 1.53 @@ -110,21 +110,21 @@ will be evaluated whenever a complete list of buffers is needed (to set up all buffers to prepare for undo, and to check them all for changes after `body' has run)." - (let ((buffer-sym (gensym))) - `(progn - (dolist (,buffer-sym ,get-buffers-exp) - (setf (undo-accumulate ,buffer-sym) '())) - (unwind-protect (progn , at body) - (dolist (,buffer-sym ,get-buffers-exp) - (cond ((null (undo-accumulate ,buffer-sym)) nil) - ((null (cdr (undo-accumulate ,buffer-sym))) - (add-undo (car (undo-accumulate ,buffer-sym)) - (undo-tree ,buffer-sym))) - (t - (add-undo (make-instance 'compound-record - :buffer ,buffer-sym - :records (undo-accumulate ,buffer-sym)) - (undo-tree ,buffer-sym))))))))) + (with-gensyms (buffer) + `(progn + (dolist (,buffer ,get-buffers-exp) + (setf (undo-accumulate ,buffer) '())) + (unwind-protect (progn , at body) + (dolist (,buffer ,get-buffers-exp) + (cond ((null (undo-accumulate ,buffer)) nil) + ((null (cdr (undo-accumulate ,buffer))) + (add-undo (car (undo-accumulate ,buffer)) + (undo-tree ,buffer))) + (t + (add-undo (make-instance 'compound-record + :buffer ,buffer + :records (undo-accumulate ,buffer)) + (undo-tree ,buffer))))))))) (defmethod flip-undo-record :around ((record climacs-undo-record)) (with-slots (buffer) record --- /project/climacs/cvsroot/climacs/packages.lisp 2006/09/06 20:07:21 1.117 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/11 20:13:32 1.118 @@ -26,6 +26,14 @@ (in-package :cl-user) +(defpackage :climacs-utils + (:use :clim-lisp) + (:export #:with-gensyms + #:once-only + #:unlisted + #:fully-unlisted + #:listed)) + (defpackage :climacs-buffer (:use :clim-lisp :flexichain :binseq) (:export #:buffer #:standard-buffer @@ -76,7 +84,7 @@ (:documentation "An implementation of a kill ring.")) (defpackage :climacs-base - (:use :clim-lisp :climacs-buffer :climacs-kill-ring :esa-buffer) + (:use :clim-lisp :climacs-buffer :climacs-kill-ring :esa-buffer :climacs-utils) (:export #:as-offsets #:do-buffer-region #:do-buffer-region-lines @@ -118,7 +126,7 @@ #:add-abbrev)) (defpackage :climacs-syntax - (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) + (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain :climacs-utils) (:export #:syntax #:define-syntax #:*default-syntax* #:eval-option #:define-option-for-syntax @@ -170,7 +178,7 @@ (defpackage :climacs-pane (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev - :climacs-syntax :flexichain :undo :esa-buffer :esa-io) + :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 @@ -378,7 +386,8 @@ (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-editing :climacs-gui :clim :climacs-abbrev :esa :esa-buffer :esa-io + :climacs-utils) (:export #:display-string #:object-equal #:object= @@ -484,7 +493,7 @@ (defpackage :climacs-lisp-syntax (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base :climacs-syntax :climacs-fundamental-syntax :flexichain :climacs-pane :climacs-gui - :climacs-motion :climacs-editing :climacs-core) + :climacs-motion :climacs-editing :climacs-core :climacs-utils) (:export #:lisp-string #:edit-definition)) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/11 08:55:21 1.113 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/11 20:13:32 1.114 @@ -28,21 +28,6 @@ ;;; ;;; Convenience functions and macros: -(defun unlisted (obj &optional (fn #'first)) - (if (listp obj) - (funcall fn obj) - obj)) - -(defun fully-unlisted (obj &optional (fn #'first)) - (if (listp obj) - (fully-unlisted (funcall fn obj)) - obj)) - -(defun listed (obj) - (if (listp obj) - obj - (list obj))) - (defun usable-package (package-designator) "Return a usable package based on `package-designator'." (or (find-package package-designator) --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/11 08:55:21 1.5 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/11 20:13:32 1.6 @@ -741,33 +741,29 @@ (preceding-operand-sym (or preceding-operand (gensym))) (operands-sym (or operands (gensym))) (form-sym (or form (gensym))) - (operand-indices-sym (or preceding-operand-indices (gensym))) - ;; My kingdom for with-gensyms (or once-only)! - (mark-value-sym (gensym)) - (syntax-value-sym (gensym))) - `(let* ((,mark-value-sym ,mark-or-offset) - (,syntax-value-sym ,syntax) - (,form-sym - ;; Find a form with a valid (fboundp) operator. - (let ((immediate-form - (preceding-form ,mark-value-sym ,syntax-value-sym))) - (unless (null immediate-form) - (or (find-applicable-form ,syntax-value-sym immediate-form) - ;; If nothing else can be found, and `arg-form' - ;; is the operator of its enclosing form, we use - ;; the enclosing form. - (when (eq (first-form (children (parent immediate-form))) immediate-form) - (parent immediate-form)))))) - ;; If we cannot find a form, there's no point in looking - ;; up any of this stuff. - (,operator-sym (when ,form-sym (form-operator ,form-sym ,syntax-value-sym))) - (,operands-sym (when ,form-sym (form-operands ,form-sym ,syntax-value-sym)))) - (declare (ignorable ,mark-value-sym ,syntax-value-sym ,form-sym - ,operator-sym ,operands-sym)) - (multiple-value-bind (,preceding-operand-sym ,operand-indices-sym) - (when ,form-sym (find-operand-info ,syntax-value-sym ,mark-value-sym ,form-sym)) - (declare (ignorable ,preceding-operand-sym ,operand-indices-sym)) - , at body)))) + (operand-indices-sym (or preceding-operand-indices (gensym)))) + (once-only (mark-or-offset syntax) + `(declare (ignorable ,mark-or-offset ,syntax)) + `(let* ((,form-sym + ;; Find a form with a valid (fboundp) operator. + (let ((immediate-form + (preceding-form ,mark-or-offset ,syntax))) + (unless (null immediate-form) + (or (find-applicable-form ,syntax immediate-form) + ;; If nothing else can be found, and `arg-form' + ;; is the operator of its enclosing form, we use + ;; the enclosing form. + (when (eq (first-form (children (parent immediate-form))) immediate-form) + (parent immediate-form)))))) + ;; If we cannot find a form, there's no point in looking + ;; up any of this stuff. + (,operator-sym (when ,form-sym (form-operator ,form-sym ,syntax))) + (,operands-sym (when ,form-sym (form-operands ,form-sym ,syntax)))) + (declare (ignorable ,form-sym ,operator-sym ,operands-sym)) + (multiple-value-bind (,preceding-operand-sym ,operand-indices-sym) + (when ,form-sym (find-operand-info ,syntax ,mark-or-offset ,form-sym)) + (declare (ignorable ,preceding-operand-sym ,operand-indices-sym)) + , at body))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/climacs/cvsroot/climacs/groups.lisp 2006/09/08 18:12:03 1.2 +++ /project/climacs/cvsroot/climacs/groups.lisp 2006/09/11 20:13:32 1.3 @@ -273,22 +273,20 @@ `body' has run. Also, `buffers' will be bound to a list of the buffers containing the files designated by `group' while `body' is run." - (let ((buffers-before-sym (gensym)) - (buffers-after-sym (gensym)) - (buffer-diff-sym (gensym)) - (group-val-sym (gensym))) - `(let ((,buffers-before-sym (buffers *application-frame*)) - (,group-val-sym ,group)) - (ensure-group-buffers ,group-val-sym) - (let* ((,buffers-after-sym (buffers *application-frame*)) - (,buffer-diff-sym (set-difference ,buffers-after-sym - ,buffers-before-sym)) - (,buffers (group-buffers ,group-val-sym))) - (unwind-protect (progn , at body) - (unless ,keep - (loop for buffer in ,buffer-diff-sym + (with-gensyms (buffers-before buffers-after buffer-diff) + (once-only (group keep) + `(let ((,buffers-before (buffers *application-frame*)) + (,group ,group)) + (ensure-group-buffers ,group) + (let* ((,buffers-after (buffers *application-frame*)) + (,buffer-diff (set-difference ,buffers-after + ,buffers-before)) + (,buffers (group-buffers ,group))) + (unwind-protect (progn , at body) + (unless ,keep + (loop for buffer in ,buffer-diff do (save-buffer buffer) - do (kill-buffer buffer)))))))) + do (kill-buffer buffer))))))))) (defmacro define-group (name (group-arg &rest args) &body body) "Define a persistent group named `name'. `Body' should return a @@ -297,25 +295,25 @@ the first element bound to the result of evaluating the second element. The second element will be evaluated when the group is selected to be the active group by the user." - (let ((name-val-sym (gensym)) - (group-val-sym (gensym))) - `(let ((,name-val-sym ,name)) - (assert (stringp ,name-val-sym)) - (setf (gethash ,name-val-sym *persistent-groups*) - (make-instance 'custom-group - :name ,name-val-sym - :pathname-lister #'(lambda (,group-val-sym) - (destructuring-bind - (&key ,@(mapcar #'(lambda (arg) - `((,arg ,arg))) - (mapcar #'first args))) - (value-plist ,group-val-sym) - (let ((,group-arg ,group-val-sym)) - , at body))) - :select-response #'(lambda (group) - (declare (ignorable group)) - ,@(loop for (name form) in args - collect `(setf (getf (value-plist group) ',name) ,form)))))))) + (with-gensyms (group) + (once-only (name) + `(let ((,name ,name)) + (assert (stringp ,name)) + (setf (gethash ,name *persistent-groups*) + (make-instance 'custom-group + :name ,name + :pathname-lister #'(lambda (,group) + (destructuring-bind + (&key ,@(mapcar #'(lambda (arg) + `((,arg ,arg))) + (mapcar #'first args))) + (value-plist ,group) + (let ((,group-arg ,group)) + , at body))) + :select-response #'(lambda (group) + (declare (ignorable group)) + ,@(loop for (name form) in args + collect `(setf (getf (value-plist group) ',name) ,form))))))))) (define-group "Current Directory Files" (group) (declare (ignore group)) --- /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/09/02 21:43:56 1.5 +++ /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/09/11 20:13:32 1.6 @@ -1,4 +1,4 @@ -;;; -*- Mode: Lisp; Package: CLIMACS-FUNDAMENTAL-SYNTAX -*- +;; -*- Mode: Lisp; Package: CLIMACS-FUNDAMENTAL-SYNTAX -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh at labri.fr) --- /project/climacs/cvsroot/climacs/climacs.asd 2006/09/06 20:07:21 1.54 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/09/11 20:13:32 1.55 @@ -55,6 +55,7 @@ (: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")) @@ -62,9 +63,9 @@ :pathname #p"Persistent/persistent-buffer.lisp" :depends-on ("packages" "buffer" "Persistent")) - (:file "base" :depends-on ("packages" "buffer" "persistent-buffer" "kill-ring")) + (:file "base" :depends-on ("packages" "utils" "buffer" "persistent-buffer" "kill-ring")) (:file "abbrev" :depends-on ("packages" "buffer" "base")) - (:file "syntax" :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")) @@ -72,7 +73,7 @@ (:file "persistent-undo" :pathname #p"Persistent/persistent-undo.lisp" :depends-on ("packages" "buffer" "persistent-buffer" "undo")) - (:file "pane" :depends-on ("packages" "syntax" "buffer" "base" + (: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" @@ -83,7 +84,7 @@ (:file "prolog2paiprolog" :depends-on ("prolog-syntax")) (:file "ttcn3-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane")) - (:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane" + (:file "lisp-syntax" :depends-on ("packages" "utils" "syntax" "buffer" "base" "pane" "window-commands" "gui")) (:file "lisp-syntax-swine" :depends-on ("lisp-syntax")) (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "motion-commands" @@ -91,7 +92,7 @@ #.(if (find-swank) '(:file "lisp-syntax-swank" :depends-on ("lisp-syntax")) (values)) - (:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane" + (:file "gui" :depends-on ("packages" "utils" "syntax" "base" "buffer" "undo" "pane" "kill-ring" "text-syntax" "abbrev" "editing" "motion")) (:file "io" :depends-on ("packages" "gui")) --- /project/climacs/cvsroot/climacs/base.lisp 2006/09/04 07:05:21 1.60 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/09/11 20:13:32 1.61 @@ -71,8 +71,7 @@ at the beginning of the line and `body' will be executed. Note that the iteration will always start from the mark specifying the earliest position in the buffer." - (let ((mark-sym (gensym)) - (mark2-sym (gensym))) + (with-gensyms (mark-sym mark2-sym) `(progn (let* ((,mark-sym (clone-mark ,mark1)) (,mark2-sym (clone-mark ,mark2))) --- /project/climacs/cvsroot/climacs/utils.lisp 2006/09/11 20:13:33 NONE +++ /project/climacs/cvsroot/climacs/utils.lisp 2006/09/11 20:13:33 1.1 ;;; -*- Mode: Lisp; Package: CLIMACS-UTILS -*- ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas at 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. ;;; Miscellaneous utilities used in Climacs. (in-package :climacs-utils) ; Cribbed from Paul Graham (defmacro with-gensyms (syms &body body) `(let ,(mapcar #'(lambda (s) `(,s (gensym))) syms) , at body)) ; Cribbed from PCL by Seibel (defmacro once-only ((&rest names) &body body) (let ((gensyms (loop for n in names collect (gensym)))) `(let (,@(loop for g in gensyms collect `(,g (gensym)))) `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) , at body))))) (defun unlisted (obj &optional (fn #'first)) (if (listp obj) (funcall fn obj) obj)) (defun fully-unlisted (obj &optional (fn #'first)) (if (listp obj) (fully-unlisted (funcall fn obj)) obj)) (defun listed (obj) (if (listp obj) obj (list obj))) From thenriksen at common-lisp.net Tue Sep 12 17:03:52 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 12 Sep 2006 13:03:52 -0400 (EDT) Subject: [climacs-cvs] CVS climacs/Doc Message-ID: <20060912170352.2D3F474181@common-lisp.net> Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv31323/Doc Modified Files: climacs-user.texi Log Message: Changed terminology from "order" to "gesture". --- /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/09/06 17:42:08 1.14 +++ /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/09/12 17:03:51 1.15 @@ -179,8 +179,8 @@ @cindex command Such a key sequence is called a @emph{complete key sequence} @cindex complete key sequence -or an @emph{order}. - at cindex order +or a @emph{gesture}. + at cindex gesture @node Basic editing commands @chapter Basic editing commands @@ -239,7 +239,7 @@ Typically, a numeric argument prefix makes the command repeat its action a number of times indicated by the numeric argument prefix. For instance, the command @command{Delete Object}, usually associated -with the order @kbd{C-d}, normally deletes a single object from the +with the gesture @kbd{C-d}, normally deletes a single object from the buffer. However, if given a numeric argument, it deletes that many objects. @@ -262,7 +262,7 @@ command. One way is to first type @kbd{C-u}, @kindex C-u then a sequence of -decimal digits, and finally the order that invokes the command. For +decimal digits, and finally the gesture that invokes the command. For instance, to delete the next 15 objects after point, you could type @kbd{C-u 1 5 C-d}. The other way is to hold down the @key{Meta} key (usually the one marked @key{Alt}) while typing the decimal digits, as @@ -300,19 +300,19 @@ To delete an object @emph{to the right} of the point, use the @kbd{C-d} @kindex C-d -(@command{Delete Object}) order. When used with a numeric +(@command{Delete Object}) gesture. When used with a numeric argument, these commands delete that many objects. @node Deleting by words @subsection Deleting by words It is also possible to delete larger chunks of buffer contents. The -order @kbd{M-d} +gesture @kbd{M-d} @kindex M-d (@command{Kill Word}) is used to delete the @emph{word} @cindex word @emph{following} point. If point is not at the beginning of a word, -then the part of the word that follows point is deleted. The order +then the part of the word that follows point is deleted. the gesture @kbd{M- at key{Backspace}} @kindex M- at key{Backspace} (@command{Backward Kill Word}) is used to @@ -326,7 +326,7 @@ @subsection Deleting by lines @climacs{} allows you to delete buffer objects one or more lines at a -time. The order @kbd{C-k} +time. The gesture @kbd{C-k} @kindex C-k (@command{Kill Line}) lets you do this. When point is @emph{not} at the end of a line, then this command kills the buffer contents from @@ -357,14 +357,14 @@ The most frequent way of moving around is by one buffer position at a time. -The order @kbd{C-f} +The gesture @kbd{C-f} @kindex C-f (@command{Forward Object}) allows you to advance the position of point by one position. If given a numeric argument, it advances by that many positions. The @command{Forward Object} command is also associated with the @emph{right-arrow key}. -The order @kbd{C-b} +The gesture @kbd{C-b} @kindex C-b (@command{Backward Object}) allows you to move the position of point backward by one position. If given a numeric @@ -377,14 +377,14 @@ @climacs{} will allow you to move around by larger units than objects. -The order @kbd{M-f} +The gesture @kbd{M-f} @kindex M-f (@command{Forward Word}) lets you move forward over the @emph{word} @cindex word following point. With a numeric argument, this command moves point forward that many words. -The order @kbd{M-b} +The gesture @kbd{M-b} @kindex M-b (@command{Backward Word}) lets you move backward over the @emph{word} @cindex word @@ -401,7 +401,7 @@ @climacs{} has commands to move by one or several @emph{lines} at a time. -The order @kbd{C-p} +The gesture @kbd{C-p} @kindex C-p (@command{Previous Line}) allows you to move point @emph{up} to the previous line. If given a numeric @@ -409,7 +409,7 @@ @command{Previous Line} is also associated with the @emph{up-arrow key}. -The order @kbd{C-n} +The gesture @kbd{C-n} @kindex C-n (@command{Next Line}) allows you to move point @emph{down} to the next line. If given a numeric @@ -431,7 +431,7 @@ In order to make editing as efficient as possible, many @climacs{} commands can be invoked by key sequences. It is, however, possible to -invoke most @climacs{} commands by using the order @kbd{M-x} which +invoke most @climacs{} commands by using the gesture @kbd{M-x} which invokes the command @command{Extended Command} which lets you type the @emph{name} of the command in the minibuffer at the prompt. In general, you do not have to type the full name of the command, @@ -467,7 +467,7 @@ @node Finding a file @subsection Finding a file -To find a file, use the order @kbd{C-x C-f} +To find a file, use the gesture @kbd{C-x C-f} @kindex C-x C-f (@command{Find File}). @@ -483,7 +483,7 @@ @node Saving a buffer @subsection Saving a buffer -To save a buffer, use the order @kbd{C-x C-s} +To save a buffer, use the gesture @kbd{C-x C-s} @kindex C-x C-s (@command{Save Buffer}). The contents of the buffer will be transfered to the file associated @@ -495,7 +495,7 @@ @subsection Writing a buffer @anchor{write-buffer} -To write a buffer to a file, use the order @kbd{C-x C-w} +To write a buffer to a file, use the gesture @kbd{C-x C-w} @kindex C-x C-w (@command{Write Buffer}). @climacs{} will prompt for the name of a file to save the buffer contents in. Completion (by using the @@ -602,22 +602,22 @@ @node Group commands @section Group commands -Specific groups can be defined by using the order @kbd{C-x g d} +Specific groups can be defined by using the gesture @kbd{C-x g d} @kindex C-x g d (@command{Define Group}). You will be queried for a name for the group and a list of buffers, and a group with the specified name and buffers will be created and selected as the active group. Alternatively, you can -use the order @kbd{C-x g f} +use the gesture @kbd{C-x g f} @kindex C-x g f (@command{Define File Group}, which will query for files instead of buffers. If you wish to select an already existing group (persistent or -specific) as the active group, you can use the order @kbd{C-x g s}. +specific) as the active group, you can use the gesture @kbd{C-x g s}. @kindex C-x g s -You can deselect the active group with the order @kbd{C-x g u} +You can deselect the active group with the gesture @kbd{C-x g u} @kindex C-x g u (@command{Deselect Group}) - this will usually make all group-aware commands operate on just the current buffer. To see which group is the -active group, use the order @kbd{C-x g c} +active group, use the gesture @kbd{C-x g c} @kindex C-x g c (@command{Current Group}), and to see the buffers and files designated by the active group, use @kbd{C-x g l} (@command{List Group Contents}). @@ -641,20 +641,20 @@ the keyboard, and then making it possibly to @emph{replay} the recorded sequence. -To start recording a sequence of keystrokes, use the order @kbd{C-x (} +To start recording a sequence of keystrokes, use the gesture @kbd{C-x (} @kindex C-x ( (@command{Start Kbd Macro}). You will see the word @samp{Def} appearing on the mode line, indicating that a keyboard macro is being defined. As long as recording is in effect, every keystroke will be saved for later use. -To stop recording a sequence of keystrokes, use the order @kbd{C-x )} +To stop recording a sequence of keystrokes, use the gesture @kbd{C-x )} @kindex C-x ) (@command{End Kbd Macro}). The word @samp{Def} will disappear from the mode line, indicating that keystrokes are no longer being recorded. -To replay a previously recorded sequence of keystrokes, use the order +To replay a previously recorded sequence of keystrokes, use the gesture @kbd{C-x e} @kindex C-x e (@command{Call Last Kbd Macro}). When used with a numeric argument, @@ -713,7 +713,7 @@ immediate feedback while entering the search string. Incremental search is controlled through a command loop. @xref{The isearch command loop}. -Incremental search can be entered via two orders, @kbd{C-s} +Incremental search can be entered via two gestures, @kbd{C-s} @kindex C-s (@command{Isearch Forward}) and @kbd{C-r} @kindex C-r @@ -729,7 +729,7 @@ the search string, and @climacs{} moving point ahead to the most immediate instance of the provided string, while the user is typing. Apart from simply entering text, the user can manipulate the command loop by -entering the following orders: +entering the following gestures: @table @kbd @item C-s @@ -749,7 +749,7 @@ @item @key{Backspace} Delete the last element of the search string. This is not the same as deleting the last character - for example, if the word at point has been -appended to the search string via @kbd{C-w}, this order will delete the +appended to the search string via @kbd{C-w}, this gesture will delete the entire word, not just the last character of the word. @item @key{Newline} Exit the isearch command loop. @@ -758,14 +758,14 @@ @node Replacing single strings @subsection Replacing single strings -The basic string-replacement command can be accessed through the order +The basic string-replacement command can be accessed through the gesture @kbd{C-x e} @kindex C-x e (@command{Replace String}). This command will prompt for two strings, and replace all instances of the first string following point in the current buffer, with the second string. This command is not querying, and will thus not prompt before each replacement, so if you desire this -behavior, use the order @kbd{M-%} +behavior, use the gesture @kbd{M-%} @kindex M-% (@command{Query Replace}) instead. @xref{The query-replace command loop}. @@ -795,7 +795,7 @@ process. The command loop will loop across the buffer, and for each match, the -command loop will read an order from the user. The following orders and +command loop will read a gesture from the user. The following gestures and their corresponding commands are available: @table @kbd @@ -818,7 +818,7 @@ In addition to this manual, @climacs{} contains an online help facility. There are several different topics that you can get help -with. Most of these topics are obtained by some order using the +with. Most of these topics are obtained by some gesture using the @kbd{C-h} @kindex C-h prefix key. The key following @kbd{C-h} determines what kind of help @@ -829,13 +829,13 @@ * Help with a key binding:: * Help with a particular key sequence:: * Help finding a command:: -* Help finding an order for a command:: +* Help finding a gesture for a command:: @end menu @node Help with a command @section Help with a command -To get documentation about a particular command, use the order @kbd{C-h +To get documentation about a particular command, use the gesture @kbd{C-h f} @kindex C-h f (@command{Describe Command}). You will be prompted for the name of a @@ -847,24 +847,24 @@ @node Help with a key binding @section Help with a key binding -To obtain a list of all orders and the associated commands that are -valid in a particular context, use the order @kbd{C-h b} +To obtain a list of all gestures and the associated commands that are +valid in a particular context, use the gesture @kbd{C-h b} @kindex C-h b (@command{Describe Bindings}). A table with each command name and -associated order (if any) is displayed in a new window. +associated gesture (if any) is displayed in a new window. @node Help with a particular key sequence @section Help with a particular key sequence -To obtain a description of what some putative order will do, use the -order @kbd{C-h c}p +To obtain a description of what some putative gesture will do, use the +gesture @kbd{C-h c}p @kindex C-h c (@command{Describe Key Briefly}). You will be prompted for a key sequence. If the key sequence you type is bound to a command, the command name will be displayed in the minibuffer. Otherwise, a message indicating that the key is not bound to a command will be displayed. -For more detailed information, use the order @kbd{C-h c} +For more detailed information, use the gesture @kbd{C-h c} @kindex C-h k (@command{Describe Key}). You will be prompted for a key sequence, and if the key sequence you provide is bound to a command, documentation for @@ -875,7 +875,7 @@ @section Help finding a command If you do not know which commands are applicable to a given situation, -you can use the order @kbd{C-h a} +you can use the gesture @kbd{C-h a} @kindex C-h a (@command{Apropos Command}) to perform a keyword-based search for commands. You will be prompted for a keyword, after which @climacs{} @@ -885,18 +885,18 @@ them. You can also click on the names of the commands to get more thorough documentation. - at node Help finding an order for a command - at section Help finding an order for a command + at node Help finding a gesture for a command + at section Help finding a gesture for a command Sometimes, you know the name of a command, and would like to find out -whether it is bound to any order, and if so, which one(s). For that, -you can use the order @kbd{C-h w} +whether it is bound to any gesture, and if so, which one(s). For that, +you can use the gesture @kbd{C-h w} @kindex C-h w (@command{Where Is}). You will be prompted for a command name (completion can be used as usual), and if the command name given is -bound to an order, that order will displayed in the minibuffer. +bound to a a gesture, that gesture will displayed in the minibuffer. Otherwise, a message indicating that the command is not bound to any -order will be displayed. +gesture will be displayed. @node Proposal for new buffer/pane relations @chapter Proposal for new buffer/pane relations From thenriksen at common-lisp.net Tue Sep 12 17:24:57 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 12 Sep 2006 13:24:57 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060912172457.1F84D78037@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv1177 Modified Files: lisp-syntax.lisp lisp-syntax-swine.lisp lisp-syntax-commands.lisp climacs.asd Log Message: Added proof-of-concept group to the Lisp syntax, and abstracted away some of the type-checking to functions. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/11 20:13:32 1.114 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/12 17:24:56 1.115 @@ -1408,7 +1408,7 @@ end-offset)) (typep x 'complete-list-form)) (let ((candidate (first-form (children x)))) - (and (typep candidate 'token-mixin) + (and (form-token-p candidate) (eq (token-to-object syntax candidate :no-error t) 'cl:in-package))))))) @@ -1421,16 +1421,16 @@ (loop for (offset . nil) in (package-list syntax) unless (let ((form (form-around syntax offset))) - (and form (typep form 'complete-list-form))) + (form-list-p form)) do (return t))))))) (defun update-package-list (buffer syntax) (declare (ignore buffer)) (setf (package-list syntax) nil) (flet ((test (x) - (when (typep x 'complete-list-form) + (when (form-list-p x) (let ((candidate (first-form (children x)))) - (and (typep candidate 'token-mixin) + (and (form-token-p candidate) (eq (token-to-object syntax candidate :no-error t) 'cl:in-package))))) @@ -1473,13 +1473,13 @@ (defun first-noncomment (list) "Returns the first non-comment in list." - (find-if-not #'(lambda (item) (typep item 'comment)) list)) + (find-if-not #'comment-p list)) (defun rest-noncomments (list) "Returns the remainder of the list after the first non-comment, stripping leading comments." (loop for rest on list - count (not (typep (car rest) 'comment)) + count (not (comment-p (car rest))) into forms until (= forms 2) finally (return rest))) @@ -1487,7 +1487,7 @@ (defun nth-noncomment (n list) "Returns the nth non-comment in list." (loop for item in list - count (not (typep item 'comment)) + count (not (comment-p item)) into forms until (> forms n) finally (return item))) @@ -1508,7 +1508,7 @@ "Returns the remainder of the list after the first form, stripping leading non-forms." (loop for rest on list - count (typep (car rest) 'form) + count (formp (car rest)) into forms until (= forms 2) finally (return rest))) @@ -1516,7 +1516,7 @@ (defun nth-form (n list) "Returns the nth form in list or `nil'." (loop for item in list - count (typep item 'form) + count (formp item) into forms until (> forms n) finally (when (> forms n) @@ -1538,26 +1538,21 @@ "Returns the third formw in list." (nth-form 2 list)) -(defgeneric form-operator (form syntax) - (:documentation "Return the operator of `form' as a Lisp -object. Returns nil if none can be found.") +(defgeneric form-operator (syntax form) + (:documentation "Return the operator of `form' as a + token. Returns nil if none can be found.") (:method (form syntax) nil)) -(defmethod form-operator ((form list-form) syntax) - (let* ((operator-token (first-form (rest (children form)))) - (operator-symbol (when operator-token - (token-to-object syntax operator-token :no-error t)))) - operator-symbol)) +(defmethod form-operator (syntax (form list-form)) + (first-form (rest (children form)))) -(defgeneric form-operands (form syntax) +(defgeneric form-operands (syntax form) (:documentation "Returns the operands of `form' as a list of - Lisp objects. Returns nil if none can be found.") + tokens. Returns nil if none can be found.") (:method (form syntax) nil)) -(defmethod form-operands ((form list-form) syntax) - (loop for operand in (rest-forms (children form)) - when (typep operand 'form) - collect (token-to-object syntax operand :no-error t))) +(defmethod form-operands (syntax (form list-form)) + (remove-if-not #'formp (rest-forms (children form)))) (defun form-toplevel (form syntax) "Return the top-level form of `form'." @@ -1565,15 +1560,15 @@ form (form-toplevel (parent form) syntax))) -(defgeneric operator-p (token syntax) +(defgeneric form-operator-p (token syntax) (:documentation "Return true if `token' is the operator of its form. Otherwise, return nil.") (:method (token syntax) (with-accessors ((pre-token preceding-parse-tree)) token (cond ((typep pre-token 'left-parenthesis-lexeme) t) - ((typep pre-token 'comment) - (operator-p pre-token syntax)) + ((comment-p pre-token) + (form-operator-p pre-token syntax)) (t nil))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1604,9 +1599,9 @@ \"unwrap\" quote-forms in order to return the symbol token. If no symbol token can be found, NIL will be returned." (labels ((unwrap-form (form) - (cond ((typep form 'quote-form) + (cond ((form-quoted-p form) (unwrap-form (first-form (children form)))) - ((typep form 'complete-token-lexeme) + ((form-token-p form) form)))) (unwrap-form (expression-at-mark mark-or-offset syntax)))) @@ -1614,7 +1609,7 @@ "Return the top token object for `token', return `token' or the top quote-form that `token' is buried in. " (labels ((ascend (form) - (cond ((typep (parent form) 'quote-form) + (cond ((form-quoted-p (parent form)) (ascend (parent form))) (t form)))) (ascend token))) @@ -1623,7 +1618,7 @@ "Return the bottom token object for `token', return `token' or the form that `token' quotes, peeling away all quote forms." (labels ((descend (form) - (cond ((typep form 'quote-form) + (cond ((form-quoted-p form) (descend (first-form (children form)))) (t form)))) (descend token))) @@ -1660,6 +1655,32 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Querying forms for data + +(defmacro define-form-predicate (name (&rest t-classes) &optional documentation) + "Define a generic function named `name', taking a single + argument. A default method that returns NIL will be defined, + and methods returning T will be defined for all classes in + `t-classes'." + `(progn + (defgeneric ,name (form) + (:documentation ,(or documentation "Check `form' for something.")) + (:method (form) nil)) + ,@(loop for class in t-classes collecting + `(defmethod ,name ((form ,class)) + t)))) + +(define-form-predicate formp (form)) +(define-form-predicate form-list-p (complete-list-form incomplete-list-form)) +(define-form-predicate form-incomplete-p (incomplete-form-mixin)) +(define-form-predicate form-token-p (token-mixin)) +(define-form-predicate form-string-p (string-form)) +(define-form-predicate form-quoted-p (quote-form backquote-form)) + +(define-form-predicate comment-p (comment)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Useful functions for modifying forms based on the mark. (defun replace-symbol-at-mark (mark syntax string) @@ -1792,11 +1813,11 @@ (with-face (:lambda-list-keyword) (call-next-method))) ((and (macro-function symbol) - (operator-p parse-symbol syntax)) + (form-operator-p parse-symbol syntax)) (with-face (:macro) (call-next-method))) ((and (special-operator-p symbol) - (operator-p parse-symbol syntax)) + (form-operator-p parse-symbol syntax)) (with-face (:special-form) (call-next-method))) (t (call-next-method)))))) @@ -1910,7 +1931,7 @@ (nthcdr 2 (remove-if - #'(lambda (child) (typep child 'comment)) + #'comment-p children)))) (type-string (token-string syntax type)) (type-symbol (parse-symbol type-string :package +keyword-package+))) @@ -1971,7 +1992,7 @@ (defun form-before-in-children (children offset) (loop for (first . rest) on children - if (typep first 'form) + if (formp first) do (cond ((< (start-offset first) offset (end-offset first)) (return (if (null (children first)) @@ -1981,14 +2002,14 @@ (or (null (first-form rest)) (<= offset (start-offset (first-form rest))))) (return (let ((potential-form - (when (typep first 'list-form) + (when (form-list-p first) (form-before-in-children (children first) offset)))) (if (not (null potential-form)) (if (<= (end-offset first) (end-offset potential-form)) potential-form first) - (when (typep first 'form) + (when (formp first) first))))) (t nil)))) @@ -2001,7 +2022,7 @@ (defun form-after-in-children (children offset) (loop for child in children - if (typep child 'form) + if (formp child) do (cond ((< (start-offset child) offset (end-offset child)) (return (if (null (children child)) nil @@ -2013,7 +2034,7 @@ (start-offset potential-form)) child potential-form) - (when (typep child 'form) + (when (formp child) child))))) (t nil)))) @@ -2026,15 +2047,15 @@ (defun form-around-in-children (children offset) (loop for child in children - if (typep child 'form) + if (formp child) do (cond ((or (<= (start-offset child) offset (end-offset child)) (= offset (end-offset child)) (= offset (start-offset child))) (return (if (null (first-form (children child))) - (when (typep child 'form) + (when (formp child) child) (or (form-around-in-children (children child) offset) - (when (typep child 'form) + (when (formp child) child))))) ((< offset (start-offset child)) (return nil)) @@ -2054,7 +2075,7 @@ that returns an offset when applied to a token (eg. `start-offset' or `end-offset'). If a list parent cannot be found, return `fn' applied to `form'." - (when (not (typep form 'form*)) + (when (not (formp form)) (let ((parent (parent form))) (typecase parent (form* (funcall fn form)) @@ -2070,7 +2091,7 @@ be found, return nil." (labels ((has-list-child (form) (some #'(lambda (child) - (if (and (typep child 'list-form) + (if (and (form-list-p child) (>= (start-offset child) min-offset)) child @@ -2108,7 +2129,7 @@ (and (= start (end-offset potential-form)) (null (form-after syntax start)))) - when (typep potential-form 'list-form) + when (form-list-p potential-form) do (setf (offset mark) (end-offset potential-form)) (return t))) @@ -2126,7 +2147,7 @@ (and (= start (start-offset potential-form)) (null (form-before syntax start)))) - when (typep potential-form 'list-form) + when (form-list-p potential-form) do (setf (offset mark) (start-offset potential-form)) (return t))) @@ -2182,14 +2203,14 @@ (with-slots (stack-top) syntax (loop for form in (children stack-top) with last-toplevel-list = nil - when (and (typep form 'form) + when (and (formp form) (mark< mark (end-offset form))) do (if (mark< (start-offset form) mark) (setf (offset mark) (start-offset form)) (when last-toplevel-list form (setf (offset mark) (start-offset last-toplevel-list)))) (return t) - when (typep form 'form) + when (formp form) do (setf last-toplevel-list form) finally (when last-toplevel-list form (setf (offset mark) @@ -2199,7 +2220,7 @@ (defmethod forward-one-definition (mark (syntax lisp-syntax)) (with-slots (stack-top) syntax (loop for form in (children stack-top) - when (and (typep form 'form) + when (and (formp form) (mark< mark (end-offset form))) do (setf (offset mark) (end-offset form)) (loop-finish) @@ -2441,7 +2462,7 @@ if (typep child 'comma-at-form) ;; How should we handle this? collect (apply #'token-to-object syntax child args) - else if (typep child 'form) + else if (formp child) collect (apply #'token-to-object syntax child args))) (defmethod token-to-object (syntax (token simple-vector-form) &key) @@ -2466,7 +2487,7 @@ ;; convenience function. (defmethod token-to-object (syntax (token backquote-form) &rest args) (let ((backquoted-form (first-form (children token)))) - (if (typep backquoted-form 'list-form) + (if (form-list-p backquoted-form) `'(,@(apply #'token-to-object syntax backquoted-form args)) `',(apply #'token-to-object syntax backquoted-form args)))) @@ -2485,7 +2506,7 @@ (defmethod token-to-object (syntax (token cons-cell-form) &key) (let ((components (remove-if #'(lambda (token) - (not (typep token 'form))) + (not (formp token))) (children token)))) (if (<= (length components) 2) (cons (token-to-object syntax (first components)) @@ -2548,7 +2569,7 @@ ;; before first element (values tree 1) (let ((first-child (elt-noncomment (children tree) 1))) - (cond ((and (typep first-child 'token-mixin) + (cond ((and (form-token-p first-child) (token-to-object syntax first-child)) (compute-list-indentation syntax (token-to-object syntax first-child) tree path)) ((null (cdr path)) @@ -2730,9 +2751,8 @@ (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'defmethod)) tree path) - (let ((lambda-list-pos (position-if (lambda (x) (typep x 'list-form)) - (remove-if - (lambda (x) (typep x 'comment)) (children tree))))) + (let ((lambda-list-pos (position-if #'form-list-p + (remove-if #'comment-p (children tree))))) (cond ((null (cdr path)) ;; top level (values tree (if (or (null lambda-list-pos) @@ -2792,7 +2812,7 @@ ;; the symbol existing in the current image. (Arguably, too, ;; this is a broken indentation form because it doesn't carry ;; over to the implicit tagbodies in macros such as DO. - (if (typep (elt-noncomment (children tree) (car path)) 'token-mixin) + (if (form-token-p (elt-noncomment (children tree) (car path))) (values tree 2) (values tree 4)) (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) @@ -2884,3 +2904,18 @@ (defmethod uncomment-region ((syntax lisp-syntax) mark1 mark2) [17 lines skipped] --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/11 20:13:32 1.6 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/12 17:24:56 1.7 @@ -349,7 +349,7 @@ (when (parent operand-form) (let ((form-operand-list (remove-if #'(lambda (form) - (or (not (typep form 'form)) + (or (not (formp form)) (eq form operator))) (children (parent operand-form))))) @@ -388,8 +388,7 @@ (if (or (and candidate-before (typep candidate-before 'incomplete-list-form)) (and (null candidate-before) - (typep (or candidate-after candidate-around) - 'list-form))) + (form-list-p (or candidate-after candidate-around)))) ;; HACK: We should not attempt to find the location of ;; the list form itself, so we create a new parser ;; symbol, attach the list form as a parent and try to @@ -689,7 +688,7 @@ ((listp argument) `(((= (first indices) ,index) ,(if (eq (first argument) 'quote) - `(cond ((typep token 'quote-form) + `(cond ((form-quoted-p token) (complete-argument-of-type ',(second argument) syntax token all-completions)) (t (call-next-method))) `(cond ((not (null (rest indices))) @@ -757,8 +756,10 @@ (parent immediate-form)))))) ;; If we cannot find a form, there's no point in looking ;; up any of this stuff. - (,operator-sym (when ,form-sym (form-operator ,form-sym ,syntax))) - (,operands-sym (when ,form-sym (form-operands ,form-sym ,syntax)))) + (,operator-sym (when ,form-sym (token-to-object ,syntax (form-operator ,syntax ,form-sym)))) + (,operands-sym (when ,form-sym (mapcar #'(lambda (operand) + (token-to-object ,syntax operand)) + (form-operands ,syntax ,form-sym))))) (declare (ignorable ,form-sym ,operator-sym ,operands-sym)) (multiple-value-bind (,preceding-operand-sym ,operand-indices-sym) (when ,form-sym (find-operand-info ,syntax ,mark-or-offset ,form-sym)) @@ -1394,7 +1395,7 @@ displayed. If no symbol can be found at `mark', return nil." (let ((token (form-around syntax (offset mark)))) (when (and (not (null token)) - (typep token 'complete-token-lexeme) + (form-token-p token) (not (= (start-offset token) (offset mark)))) (multiple-value-bind (longest completions) --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/08/20 13:10:31 1.16 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/09/12 17:24:56 1.17 @@ -69,7 +69,7 @@ (token (form-around syntax (offset (point pane)))) (fill-column (auto-fill-column pane)) (tab-width (tab-space-count (stream-default-view pane)))) - (when (typep token 'string-form) + (when (form-string-p token) (with-accessors ((offset1 start-offset) (offset2 end-offset)) token (climacs-core:fill-region (make-instance 'standard-right-sticky-mark @@ -227,7 +227,7 @@ (syntax (syntax buffer)) (mark (point pane)) (token (this-form mark syntax))) - (if (and token (typep token 'complete-token-lexeme)) + (if (and token (form-token-p token)) (com-lookup-arglist (token-to-object syntax token)) (esa:display-message "Could not find symbol at point.")))) --- /project/climacs/cvsroot/climacs/climacs.asd 2006/09/11 20:13:32 1.55 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/09/12 17:24:56 1.56 @@ -85,7 +85,7 @@ (:file "ttcn3-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane")) (:file "lisp-syntax" :depends-on ("packages" "utils" "syntax" "buffer" "base" "pane" - "window-commands" "gui")) + "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")) From thenriksen at common-lisp.net Tue Sep 12 19:49:19 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 12 Sep 2006 15:49:19 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060912194919.33FA158322@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv17172 Modified Files: core.lisp file-commands.lisp fundamental-syntax.lisp gui.lisp lisp-syntax-swine.lisp packages.lisp search-commands.lisp Log Message: Try to naively unbreak typeout panes a little more. Also some fixes related to accepting buffers. --- /project/climacs/cvsroot/climacs/core.lisp 2006/09/08 18:12:03 1.9 +++ /project/climacs/cvsroot/climacs/core.lisp 2006/09/12 19:49:18 1.10 @@ -373,38 +373,43 @@ :value-key #'identity)) :partial-completers '(#\Space) :allow-any-input t) - (cond (success - (values object type)) + (cond ((and success (plusp (length string))) + (if object + (values object type) + (values string 'string))) ((and (zerop (length string)) defaultp) - (values default default-type)) - (t (values string 'string))))) + (values default default-type)) + (t + (values string 'string))))) + +(defgeneric switch-to-buffer (pane buffer)) + +(defmethod switch-to-buffer ((pane extended-pane) (buffer climacs-buffer)) + (with-accessors ((buffers buffers)) *application-frame* + (let* ((position (position buffer buffers)) + (pane (current-window))) + (when position + (setf buffers (delete buffer buffers))) + (push buffer buffers) + (setf (offset (point (buffer pane))) (offset (point pane))) + (setf (buffer pane) buffer) + (full-redisplay pane) + buffer))) + +(defmethod switch-to-buffer ((pane typeout-pane) (buffer climacs-buffer)) + (let ((usable-pane (or (find-if #'(lambda (pane) + (typep pane 'extended-pane)) + (windows *application-frame*)) + (split-window t)))) + (switch-to-buffer usable-pane buffer))) -(defgeneric switch-to-buffer (buffer)) - -(defmethod switch-to-buffer ((buffer climacs-buffer)) - (let* ((buffers (buffers *application-frame*)) - (position (position buffer buffers)) - (pane (current-window))) - (when position - (setf buffers (delete buffer buffers))) - (push buffer (buffers *application-frame*)) - (setf (offset (point (buffer pane))) (offset (point pane))) - (setf (buffer pane) buffer) - (full-redisplay pane) - buffer)) - -(defmethod switch-to-buffer ((name string)) +(defmethod switch-to-buffer (pane (name string)) (let ((buffer (find name (buffers *application-frame*) :key #'name :test #'string=))) - (switch-to-buffer (or buffer + (switch-to-buffer pane + (or buffer (make-new-buffer :name name))))) -;;placeholder -(defmethod switch-to-buffer ((symbol (eql 'nil))) - (let ((default (second (buffers *application-frame*)))) - (when default - (switch-to-buffer default)))) - ;; ;;; FIXME: see the comment by (SETF SYNTAX) :AROUND. -- CSR, ;; ;;; 2005-10-31. ;; (defmethod (setf buffer) :around (buffer (pane extended-pane)) --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/08/20 13:06:39 1.24 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/09/12 19:49:18 1.25 @@ -224,27 +224,22 @@ ;;; ;;; Buffer commands -(define-command (com-switch-to-buffer :name t :command-table pane-table) () +(define-command (com-switch-to-buffer :name t :command-table pane-table) + ((buffer 'buffer :default (or (second (buffers *application-frame*)) + (any-buffer)))) "Prompt for a buffer name and switch to that buffer. -If the a buffer with that name does not exist, create it. Uses the name of the next buffer (if any) as a default." - (let* ((default (second (buffers *application-frame*))) - (buffer (if default - (accept 'buffer - :prompt "Switch to buffer" - :default default) - (accept 'buffer - :prompt "Switch to buffer")))) - (switch-to-buffer buffer))) +If the a buffer with that name does not exist, create it. Uses +the name of the next buffer (if any) as a default." + (switch-to-buffer (current-window) buffer)) -(set-key 'com-switch-to-buffer +(set-key `(com-switch-to-buffer ,*unsupplied-argument-marker*) 'pane-table '((#\x :control) (#\b))) (define-command (com-kill-buffer :name t :command-table pane-table) ((buffer 'buffer :prompt "Kill buffer" - :default (buffer (current-window)) - :default-type 'buffer)) + :default (buffer (current-window)))) "Prompt for a buffer name and kill that buffer. If the buffer needs saving, will prompt you to do so before killing it. Uses the current buffer as a default." (kill-buffer buffer)) @@ -253,22 +248,22 @@ 'pane-table '((#\x :control) (#\k))) -(define-command (com-toggle-read-only :name t :command-table base-table) +(define-command (com-toggle-read-only :name t :command-table buffer-table) ((buffer 'buffer :default (current-buffer *application-frame*))) (setf (read-only-p buffer) (not (read-only-p buffer)))) (define-presentation-to-command-translator toggle-read-only - (read-only com-toggle-read-only base-table + (read-only com-toggle-read-only buffer-table :gesture :menu) (object) (list object)) -(define-command (com-toggle-modified :name t :command-table base-table) +(define-command (com-toggle-modified :name t :command-table buffer-table) ((buffer 'buffer :default (current-buffer *application-frame*))) (setf (needs-saving buffer) (not (needs-saving buffer)))) (define-presentation-to-command-translator toggle-modified - (modified com-toggle-modified base-table + (modified com-toggle-modified buffer-table :gesture :menu) (object) (list object)) \ No newline at end of file --- /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/09/11 20:13:32 1.6 +++ /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/09/12 19:49:18 1.7 @@ -194,7 +194,7 @@ (let ((point (point pane))) (multiple-value-bind (cursor-x cursor-y line-height) (offset-to-screen-position (offset point) pane) - (updating-output (pane :unique-id -1 :cache-value (offset point)) + (updating-output (pane :unique-id -1 :cache-value (cons (offset point) current-p)) (draw-rectangle* pane (1- cursor-x) cursor-y (+ cursor-x 2) (+ cursor-y line-height) --- /project/climacs/cvsroot/climacs/gui.lisp 2006/09/06 20:07:21 1.230 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/09/12 19:49:18 1.231 @@ -40,6 +40,8 @@ (defclass typeout-pane (application-pane esa-pane-mixin) ()) +(defmethod full-redisplay ((pane typeout-pane))) + (defgeneric buffer-pane-p (pane) (:documentation "Returns T when a pane contains a buffer.")) @@ -119,6 +121,17 @@ (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. +(make-command-table 'typeout-pane-table + :errorp nil + :inherit-from '(global-esa-table + base-table + pane-table + window-table + development-table + climacs-help-table)) (defvar *bg-color* +white+) (defvar *fg-color* +black+) @@ -212,6 +225,10 @@ "Return the current buffer." (buffer (car (windows application-frame)))) +(defun any-buffer () + "Return some buffer, any buffer, as long as it is a buffer!" + (first (buffers *application-frame*))) + (define-presentation-type read-only ()) (define-presentation-method highlight-presentation ((type read-only) record stream state) @@ -322,15 +339,16 @@ (setf (needs-saving buffer) t))))) (defmethod find-applicable-command-table ((frame climacs)) - (or - (let ((syntax (and (buffer-pane-p (current-window)) - (syntax (buffer (current-window)))))) - (and syntax - (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))) + (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))))) (define-command (com-full-redisplay :name t :command-table base-table) () "Redisplay the contents of the current window. @@ -431,16 +449,27 @@ :width 900)))) (values vbox extended-pane))) +(defgeneric setup-split-pane (orig-pane new-pane) + (:documentation "Perform split-setup operations `new-pane', + which is supposed to be a pane that has been freshly split from + `orig-pane'.")) + +(defmethod setup-split-pane ((orig-pane extended-pane) (new-pane extended-pane)) + (setf (offset (point (buffer orig-pane))) (offset (point orig-pane)) + (buffer new-pane) (buffer orig-pane) + (auto-fill-mode new-pane) (auto-fill-mode orig-pane) + (auto-fill-column new-pane) (auto-fill-column orig-pane))) + +(defmethod setup-split-pane ((orig-pane typeout-pane) (new-pane extended-pane)) + (setf (buffer new-pane) (any-buffer))) + (defun split-window (&optional (vertically-p nil) (pane (current-window))) (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) (multiple-value-bind (vbox new-pane) (make-pane-constellation) (let* ((current-window pane) (constellation-root (find-parent current-window))) - (setf (offset (point (buffer current-window))) (offset (point current-window)) - (buffer new-pane) (buffer current-window) - (auto-fill-mode new-pane) (auto-fill-mode current-window) - (auto-fill-column new-pane) (auto-fill-column current-window)) + (setup-split-pane current-window new-pane) (push new-pane (windows *application-frame*)) (setf *standard-output* new-pane) (replace-constellation constellation-root vbox vertically-p) @@ -510,11 +539,7 @@ (setf (windows *application-frame*) (append (cdr (windows *application-frame*)) (list (car (windows *application-frame*)))))) - ;; Try to avoid setting the point in a typeout pane. FIXME: This is a kludge. - (if (and (subtypep 'typeout-pane (type-of (car (windows *application-frame*)))) - (> (length (windows *application-frame*)) 1)) - (other-window) - (setf *standard-output* (car (windows *application-frame*))))) + (setf *standard-output* (car (windows *application-frame*)))) ;;; For the ESA help functions. --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/12 17:24:56 1.7 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/12 19:49:18 1.8 @@ -1013,7 +1013,7 @@ (esa:display-message "No buffer ~A" (buffer-name location)) (beep) (return-from goto-location)) - (switch-to-buffer buffer) + (switch-to-buffer (current-window) buffer) (goto-position (point (current-window)) (char-position (source-position location))))) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/09/11 20:13:32 1.118 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/12 19:49:18 1.119 @@ -344,6 +344,7 @@ #:current-buffer #:current-point #:current-mark + #:any-buffer #:point #:syntax #:mark --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/09/06 20:07:21 1.14 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/09/12 19:49:18 1.15 @@ -318,7 +318,7 @@ (buffers buffers) (mark mark)) state (flet ((head-to-buffer (buffer) - (switch-to-buffer buffer) + (switch-to-buffer (current-window) buffer) (setf mark (point (current-window))) (beginning-of-buffer mark))) (unless (eq (current-buffer) (first buffers)) From thenriksen at common-lisp.net Thu Sep 14 14:24:01 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 14 Sep 2006 10:24:01 -0400 (EDT) Subject: [climacs-cvs] CVS climacs/Doc Message-ID: <20060914142401.0153615003@common-lisp.net> Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv30619/Doc Modified Files: climacs-internals.texi Log Message: Fixed markup errors (thanks to Daniel Katz). --- /project/climacs/cvsroot/climacs/Doc/climacs-internals.texi 2006/09/06 20:07:21 1.23 +++ /project/climacs/cvsroot/climacs/Doc/climacs-internals.texi 2006/09/14 14:24:01 1.24 @@ -2235,14 +2235,14 @@ containing the files designated by @var{group} while @var{body} is run. @end deffn - at deffn {Macro} {define-group} (name (group-arg &rest args) &body body) + at deffn {Macro} {define-group} name (group-arg &rest args) &body body Define a persistent group named @var{name}. @var{Body} should return a list of pathnames and will be used to calculate which files are designated by the group. @var{Args} should be two-element lists, with the first element bound to the result of evaluating the second element. The second element will be evaluated when the group is selected to be the active group by the user. - at node Index + at end deffn @deftp {Error Condition} group-not-found This condition is signaled whenever a synonym group is unable to find From thenriksen at common-lisp.net Fri Sep 15 22:34:25 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 15 Sep 2006 18:34:25 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060915223425.9194015003@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv7529 Modified Files: utils.lisp packages.lisp lisp-syntax.lisp lisp-syntax-swine.lisp Log Message: Added new utility function (`list-aref'), added Lisp parser recognition of incomplete quote forms, added support for "blank" completion in Lisp syntax, so you no longer need to complete from a symbol, but can get a list of all (applicable) completions. Is very, very slow when listing all possible symbols due to the "slow" McCLIM menu implementation. --- /project/climacs/cvsroot/climacs/utils.lisp 2006/09/11 20:13:32 1.1 +++ /project/climacs/cvsroot/climacs/utils.lisp 2006/09/15 22:34:24 1.2 @@ -48,4 +48,10 @@ (defun listed (obj) (if (listp obj) obj - (list obj))) \ No newline at end of file + (list obj))) + +(defun list-aref (list &rest subscripts) + (if subscripts + (apply #'list-aref (nth (first subscripts) list) + (rest subscripts)) + list)) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/09/12 19:49:18 1.119 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/15 22:34:24 1.120 @@ -32,7 +32,8 @@ #:once-only #:unlisted #:fully-unlisted - #:listed)) + #:listed + #:list-aref)) (defpackage :climacs-buffer (:use :clim-lisp :flexichain :binseq) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/12 17:24:56 1.115 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/15 22:34:24 1.116 @@ -981,7 +981,7 @@ ;;; parse trees (defclass token-form (form token-mixin) ()) (defclass complete-token-form (token-form) ()) -(defclass incomplete-token-form (token-form) ()) +(defclass incomplete-token-form (token-form incomplete-form-mixin) ()) (define-parser-state | m-e-start text* | (lexer-escaped-token-state parser-state) ()) (define-parser-state | m-e-start text* m-e-end | (lexer-toplevel-state parser-state) ()) @@ -1002,6 +1002,8 @@ ;;; parse trees (defclass quote-form (form) ()) +(defclass complete-quote-form (quote-form) ()) +(defclass incomplete-quote-form (quote-form incomplete-form-mixin) ()) (define-parser-state |' | (form-may-follow) ()) (define-parser-state |' form | (lexer-toplevel-state parser-state) ()) @@ -1009,16 +1011,25 @@ (define-new-lisp-state (form-may-follow quote-lexeme) |' |) (define-new-lisp-state (|' | form) |' form |) (define-new-lisp-state (|' | comment) |' |) - +(define-new-lisp-state (|' | unmatched-right-parenthesis-lexeme) |( form* ) |) ;;; reduce according to the rule form -> ' form (define-lisp-action (|' form | t) - (reduce-until-type quote-form quote-lexeme)) + (reduce-until-type complete-quote-form quote-lexeme)) + +(define-lisp-action (|' | right-parenthesis-lexeme) + (reduce-until-type incomplete-quote-form quote-lexeme)) +(define-lisp-action (|' | unmatched-right-parenthesis-lexeme) + (reduce-until-type incomplete-quote-form quote-lexeme)) +(define-lisp-action (|' | (eql nil)) + (reduce-until-type incomplete-quote-form quote-lexeme)) ;;;;;;;;;;;;;;;; Backquote ;;; parse trees (defclass backquote-form (form) ()) +(defclass complete-backquote-form (backquote-form) ()) +(defclass incomplete-backquote-form (backquote-form incomplete-form-mixin) ()) (define-parser-state |` | (form-may-follow) ()) (define-parser-state |` form | (lexer-toplevel-state parser-state) ()) @@ -1026,10 +1037,18 @@ (define-new-lisp-state (form-may-follow backquote-lexeme) |` |) (define-new-lisp-state (|` | form) |` form |) (define-new-lisp-state (|` | comment) |` |) +(define-new-lisp-state (|` | unmatched-right-parenthesis-lexeme) |( form* ) |) ;;; reduce according to the rule form -> ` form (define-lisp-action (|` form | t) - (reduce-until-type backquote-form backquote-lexeme)) + (reduce-until-type complete-backquote-form backquote-lexeme)) + +(define-lisp-action (|` | right-parenthesis-lexeme) + (reduce-until-type incomplete-backquote-form backquote-lexeme)) +(define-lisp-action (|` | unmatched-right-parenthesis-lexeme) + (reduce-until-type incomplete-backquote-form backquote-lexeme)) +(define-lisp-action (|` | (eql nil)) + (reduce-until-type incomplete-backquote-form backquote-lexeme)) ;;;;;;;;;;;;;;;; Comma @@ -2412,7 +2431,7 @@ incomplete tokens. This function may signal an error if `no-error' is nil and `token' cannot be converted to a Lisp object. Otherwise, nil will be returned.") - (:method :around (syntax token &rest args &key no-error package quote read) + (:method :around (syntax (token t) &rest args &key no-error package quote read) ;; Ensure that every symbol that is READ will be looked up ;; in the correct package. Also handle quoting. (flet ((act () @@ -2479,9 +2498,14 @@ (declare (ignore no-error)) (read-from-string (token-string syntax token))) -(defmethod token-to-object (syntax (token quote-form) &rest args) +(defmethod token-to-object (syntax (token complete-quote-form) &rest args) (apply #'token-to-object syntax (second (children token)) :quote t args)) +(defmethod token-to-object (syntax (token incomplete-quote-form) &rest args) + (declare (ignore args)) + ;; Utterly arbitrary, but reasonable in my opinion. + '(quote)) + ;; I'm not sure backquotes are handled correctly, but then again, ;; `token-to-object' is not meant to be a perfect Lisp reader, only a ;; convenience function. --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/12 19:49:18 1.8 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/15 22:34:24 1.9 @@ -339,9 +339,9 @@ (defun find-argument-indices-for-operand (syntax operand-form operator-form) "Return a list of argument indices for `argument-form' relative to `operator-form'. These lists take the form of (n m p), which - means (aref form-operand-list n m p). A list of - argument indices can have arbitrary length (but they are - practically always at most 2 elements long). " + means (list-aref form-operand-list n m p). A list of argument + indices can have arbitrary length (but they are practically + always at most 2 elements long). " (declare (ignore syntax)) (let ((operator (first-form (children operator-form)))) (labels ((worker (operand-form &optional the-first) @@ -482,15 +482,16 @@ argument. Return NIL if none can be found." ;; The algorithm for finding the applicable form: ;; - ;; From `arg-form', we wander up the tree looking enclosing forms, - ;; until we find a a form with an operator, the form-operator, that - ;; has `arg-form' as a direct argument (this is checked by comparing - ;; argument indices for `arg-form', relative to form-operator, with - ;; the arglist ofform-operator). However, if form-operator itself is - ;; a direct argument to one of its parents, we ignore it (unless - ;; form-operators form-operator is itself a direct argument, - ;; etc). This is so we can properly handle nested/destructuring - ;; argument lists such as those found in macros. + ;; From `arg-form', we wander up the tree looking at enclosing + ;; forms, until we find a a form with an operator, the + ;; form-operator, that has `arg-form' as a direct argument (this is + ;; checked by comparing argument indices for `arg-form', relative to + ;; form-operator, with the arglist ofform-operator). However, if + ;; form-operator itself is a direct argument to one of its parents, + ;; we ignore it (unless form-operators form-operator is itself a + ;; direct argument, etc). This is so we can properly handle + ;; nested/destructuring argument lists such as those found in + ;; macros. (labels ((recurse (candidate-form) (when (parent candidate-form) (if (and (direct-arg-p syntax (first-form (children candidate-form)) @@ -531,40 +532,48 @@ difference) (if rest-position 2 1)))))))) -(defgeneric possible-completions (syntax operator token operands indices) +(defgeneric possible-completions (syntax operator string package operands indices) (:documentation "Get the applicable completions for completing - `token' (which should be a token-lexeme), which is part of a - form with the operator `operator' (which should be a valid - operator object), and which has the operands - `operands'. `Indices' should be the argument indices from the - operator to `token' (see - `find-argument-indices-for-operands').") - (:method :around (syntax operator token operands indices) - (declare (ignore syntax operator token operands indices)) - (with-syntax-package (syntax (start-offset token)) - (call-next-method))) - (:method (syntax operator token operands indices) +`string' (which should a string of the, possibly partial, symbol +name to be completed) in `package', which is part of a form with +the operator `operator' (which should be a valid operator +object), and which has the operands `operands'. `Indices' should +be the argument indices from the operator to `token' (see +`find-argument-indices-for-operands').") + (:method (syntax operator string package operands indices) (let ((completions (first (simple-completions (get-usable-image syntax) - (token-string syntax (fully-unquoted-form token)) - (package-at-mark syntax (start-offset token)))))) + string package)))) + ;; Welcome to the ugly mess! Part of the uglyness is that we + ;; depend on Swank do to our nonobvious completion (m-v-b -> + ;; multiple-value-bind). (or (when (valid-operator-p operator) (let* ((relevant-keywords (relevant-keywords (arglist-for-form syntax operator operands) indices)) - (relevant-completions - (remove-if-not #'(lambda (compl) - (member compl relevant-keywords - :test #'(lambda (a b) - (string-equal a b - :start1 1)) - :key #'(lambda (s) - (symbol-name (fully-unlisted s))))) - (mapcar #'string-downcase completions)))) - relevant-completions)) + (keyword-completions (mapcar #'(lambda (a) + (string-downcase (format nil ":~A" a))) + relevant-keywords))) + (when relevant-keywords + ;; We need Swank to get the concrete list of + ;; possibilities, but after that, we need to filter + ;; out anything that is not a relevant keyword + ;; argument. ALSO, if `string' is blank, Swank will + ;; "helpfully" not put any keyword symbols in + ;; `completions', thus ruining this entire scheme. SO, + ;; we have to force Swank to give us a list of keyword + ;; symbols and use that instead of `completions'. Joy! + (intersection (mapcar #'string-downcase + (if (string= string "") + (first (simple-completions (get-usable-image syntax) + ":" package)) + completions)) + keyword-completions + :key #'string-downcase + :test #'string=)))) completions)))) -(defgeneric complete-argument-of-type (argument-type syntax token all-completions) +(defgeneric complete-argument-of-type (argument-type syntax string all-completions) (:documentation "") - (:method (argument-type syntax token all-completions) + (:method (argument-type syntax string all-completions) all-completions)) (defgeneric modify-argument-list (argument-type syntax arglist arguments arg-position) @@ -612,11 +621,14 @@ (remove-method #'modify-argument-list method))))))) (define-argument-type class-name () - (:completion (syntax token all-completions) - (loop for completion in all-completions - when (find-class (ignore-errors (read-from-string completion)) - nil) - collect completion)) + (:completion (syntax string all-completions) + (let ((all-lower (every #'lower-case-p string))) + (loop for completion in all-completions + when (find-class (ignore-errors (read-from-string completion)) + nil) + collect (if all-lower + (string-downcase completion) + completion)))) (:arglist-modification (syntax arglist arguments arg-position) (if (and (> (length arguments) arg-position) (listp (elt arguments arg-position)) @@ -630,10 +642,11 @@ arglist))) (define-argument-type package-designator () - (:completion (syntax token all-completions) + (:completion (syntax string all-completions) (declare (ignore all-completions)) - (let* ((string (token-string syntax token)) - (keyworded (char= (aref string 0) #\:))) + (let ((keyworded (and (plusp (length string)) + (char= (aref string 0) #\:))) + (all-upper (every #'upper-case-p string))) (loop for package in (list-all-packages) for package-name = (if keyworded (concatenate 'string ":" (package-name package)) @@ -642,7 +655,7 @@ :test #'char-equal :end2 (min (length string) (length package-name))) - collect (if (every #'upper-case-p string) + collect (if all-upper package-name (string-downcase package-name)))))) @@ -666,48 +679,53 @@ ;; FIXME: This macro should also define indentation rules. (labels ((process-keyword-arg-descs (arguments) ;; We expect `arguments' to be a plist mapping keyword - ;; symbols to type/class designators/names. We use a - ;; `case' form to map from the keyword preceding the - ;; symbol to be completed, to the code that generates the - ;; possible completions. + ;; symbols to type/class designators/names. `((t - (let* ((keyword (token-to-object syntax (form-before syntax (1- (start-offset token))))) + (let* ((keyword-indices (loop + for (car . cdr) on indices + if (null cdr) + collect (1+ car) + else collect car)) + (keyword (apply #'list-aref operands keyword-indices)) (type (getf ',arguments keyword))) (if (null type) (call-next-method) - (complete-argument-of-type type syntax token all-completions)))))) + (complete-argument-of-type type syntax string all-completions)))))) (process-arg-descs (arguments index) (let ((argument (first arguments))) - (cond ((null arguments) + (cond ((null argument) nil) ((eq argument '&rest) `(((>= (first indices) ,index) - (complete-argument-of-type ',(second arguments) syntax token all-completions)))) + (complete-argument-of-type ',(second arguments) syntax string all-completions)))) ((eq argument '&key) (process-keyword-arg-descs (rest arguments))) ((listp argument) - `(((= (first indices) ,index) - ,(if (eq (first argument) 'quote) - `(cond ((form-quoted-p token) - (complete-argument-of-type ',(second argument) syntax token all-completions)) - (t (call-next-method))) - `(cond ((not (null (rest indices))) - (pop indices) - (cond ,@(build-completions-cond-body argument))) - (t (call-next-method))))))) + (cons `((= (first indices) ,index) + ,(if (eq (first argument) 'quote) + `(cond ((eq (first (apply #'list-aref operands indices)) 'quote) + (complete-argument-of-type ',(second argument) syntax string all-completions)) + (t (call-next-method))) + `(cond ((not (null (rest indices))) + (pop indices) + (cond ,@(build-completions-cond-body argument))) + (t (call-next-method))))) + (process-arg-descs (rest arguments) + (1+ index)))) (t (cons `((= (first indices) ,index) - (complete-argument-of-type ',argument syntax token all-completions)) + (complete-argument-of-type ',argument syntax string all-completions)) (process-arg-descs (rest arguments) (1+ index))))))) (build-completions-cond-body (arguments) (append (process-arg-descs arguments 0) '((t (call-next-method)))))) `(progn - (defmethod possible-completions (syntax (operator (eql ',operator)) token operands indices) + (defmethod possible-completions (syntax (operator (eql ',operator)) string package operands indices) ,(if no-typed-completion '(call-next-method) - `(let ((all-completions (call-next-method))) + `(let* ((*package* package) + (all-completions (call-next-method))) (cond ,@(build-completions-cond-body arguments))))) ,(unless no-smart-arglist `(defmethod arglist-for-form (syntax (operator (eql ',operator)) &optional arguments) @@ -758,7 +776,8 @@ ;; up any of this stuff. (,operator-sym (when ,form-sym (token-to-object ,syntax (form-operator ,syntax ,form-sym)))) (,operands-sym (when ,form-sym (mapcar #'(lambda (operand) - (token-to-object ,syntax operand)) + (when operand + (token-to-object ,syntax operand))) (form-operands ,syntax ,form-sym))))) (declare (ignorable ,form-sym ,operator-sym ,operands-sym)) (multiple-value-bind (,preceding-operand-sym ,operand-indices-sym) @@ -1361,65 +1380,77 @@ (delete-window completions-pane) (setf completions-pane nil)))) -(defun find-completion-by-fn (fn symbol package) - (esa:display-message (format nil "~a completions" symbol)) - (let* ((result (funcall fn symbol (package-name package))) - (set (first result)) - (longest (second result))) - (values longest set))) - -(defun find-completion (syntax token) - (let* ((symbol-name (token-string syntax token)) - (result (with-code-insight (start-offset token) syntax +(defun find-completions (syntax mark-or-offset string) + "Find completions for the symbol denoted by the string `string' +at `mark-or-offset'. Two values will be returned: the common +leading string of the completions and a list of the possible +completions as strings." + (let* ((result (with-code-insight mark-or-offset syntax (:operator operator :operands operands :preceding-operand-indices indices) - (let ((completions (possible-completions syntax operator token operands indices))) + (let ((completions (possible-completions + syntax operator string + (package-at-mark syntax mark-or-offset) + operands indices))) (list completions (longest-completion completions))))) (set (first result)) (longest (second result))) - (esa:display-message (format nil "~a completions" symbol-name)) (values longest set))) -(defun find-fuzzy-completion (syntax token package) - (let ((symbol-name (token-string syntax token))) - (esa:display-message (format nil "~a completions" symbol-name)) - (let* ((set (fuzzy-completions (get-usable-image syntax) symbol-name package 10)) - (best (caar set))) - (values best set)))) +(defun find-fuzzy-completions (syntax mark-or-offset string) + "Find completions for the symbol denoted by the string +`string' at `mark-or-offset'. Two values will be returned: the +common leading string of the completions and a list of the +possible completions as strings. This function uses fuzzy logic +to find completions based on `string'." + (let* ((set (fuzzy-completions (get-usable-image syntax) string + (package-at-mark syntax mark-or-offset) + 10)) + (best (caar set))) + (values best set))) -(defun complete-symbol-at-mark-with-fn (syntax mark &optional (fn #'find-completion)) +(defun complete-symbol-at-mark-with-fn (syntax mark &optional (fn #'find-completions)) "Attempt to find and complete the symbol at `mark' using the function `fn' to get the list of completions. If the completion is ambiguous, a list of possible completions will be displayed. If no symbol can be found at `mark', return nil." - (let ((token (form-around syntax (offset mark)))) - (when (and (not (null token)) - (form-token-p token) - (not (= (start-offset token) - (offset mark)))) - (multiple-value-bind (longest completions) - (funcall fn syntax (fully-quoted-form token)) - (if (> (length longest) 0) - (if (= (length completions) 1) - (replace-symbol-at-mark mark syntax longest) - (progn - (esa:display-message (format nil "Longest is ~a|" longest)) - (let ((selection (menu-choose (mapcar - ;; FIXME: this can - ;; get ugly. - #'(lambda (completion) - (if (listp completion) - (cons completion - (first completion)) - completion)) - completions) - :label "Possible completions" - :scroll-bars :vertical))) - (replace-symbol-at-mark mark syntax (or selection - longest))))) - (esa:display-message "No completions found"))) - t))) + (let* ((token (form-around syntax (offset mark))) + (useful-token (and (not (null token)) + (form-token-p token) + (not (= (start-offset token) + (offset mark)))))) + (multiple-value-bind (longest completions) + (funcall fn syntax + (if useful-token + (start-offset (fully-quoted-form token)) + (if (form-quoted-p token) + (start-offset token) + (offset mark))) + (if useful-token + (token-string syntax token) + "")) + (if completions + (if (= (length completions) 1) + (replace-symbol-at-mark mark syntax longest) + (progn + (esa:display-message (format nil "Longest is ~a|" longest)) + (let ((selection (menu-choose (mapcar + ;; FIXME: this can + ;; get ugly. + #'(lambda (completion) + (if (listp completion) + (cons completion + (first completion)) + completion)) + completions) + :label "Possible completions" + :scroll-bars :vertical))) + (if useful-token + (replace-symbol-at-mark mark syntax (or selection longest)) + (insert-sequence mark (or selection longest)))))) + (esa:display-message "No completions found"))) + t)) (defun complete-symbol-at-mark (syntax mark) "Attempt to find and complete the symbol at `mark'. If the @@ -1432,4 +1463,4 @@ completion. If the completion is ambiguous, a list of possible completions will be displayed. If no symbol can be found at `mark', return nil." - (complete-symbol-at-mark-with-fn syntax mark #'find-fuzzy-completion)) + (complete-symbol-at-mark-with-fn syntax mark #'find-fuzzy-completions)) From thenriksen at common-lisp.net Sat Sep 16 10:30:37 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 16 Sep 2006 06:30:37 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060916103037.D7FAD16033@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv11885 Modified Files: lisp-syntax.lisp lisp-syntax-swine.lisp Log Message: More fixes regarding handling of quoted forms. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/15 22:34:24 1.116 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/16 10:30:37 1.117 @@ -1565,6 +1565,12 @@ (defmethod form-operator (syntax (form list-form)) (first-form (rest (children form)))) +(defmethod form-operator (syntax (form complete-quote-form)) + (first-form (rest (children (second (children form)))))) + +(defmethod form-operator (syntax (form complete-backquote-form)) + (first-form (rest (children (second (children form)))))) + (defgeneric form-operands (syntax form) (:documentation "Returns the operands of `form' as a list of tokens. Returns nil if none can be found.") @@ -1698,6 +1704,12 @@ (define-form-predicate comment-p (comment)) +(defgeneric form-at-top-level-p (form) + (:documentation "Return NIL if `form' is not a top-level-form, + T otherwise.") + (:method ((form t)) + (typep (parent form) 'form*))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Useful functions for modifying forms based on the mark. @@ -2013,7 +2025,8 @@ (loop for (first . rest) on children if (formp first) do - (cond ((< (start-offset first) offset (end-offset first)) + (cond ((and (< (start-offset first) offset) + (<= offset (end-offset first))) (return (if (null (children first)) nil (form-before-in-children (children first) offset)))) --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/15 22:34:24 1.9 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/16 10:30:37 1.10 @@ -1424,7 +1424,8 @@ (funcall fn syntax (if useful-token (start-offset (fully-quoted-form token)) - (if (form-quoted-p token) + (if (and (form-quoted-p token) + (form-incomplete-p token)) (start-offset token) (offset mark))) (if useful-token From thenriksen at common-lisp.net Sat Sep 16 12:11:12 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 16 Sep 2006 08:11:12 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060916121112.38ABE48144@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv881 Modified Files: lisp-syntax.lisp lisp-syntax-swine.lisp Log Message: Even more fixes regarding handling of quoted forms (now works I think). --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/16 10:30:37 1.117 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/16 12:11:11 1.118 @@ -2025,8 +2025,7 @@ (loop for (first . rest) on children if (formp first) do - (cond ((and (< (start-offset first) offset) - (<= offset (end-offset first))) + (cond ((< (start-offset first) offset (end-offset first)) (return (if (null (children first)) nil (form-before-in-children (children first) offset)))) @@ -2034,8 +2033,12 @@ (or (null (first-form rest)) (<= offset (start-offset (first-form rest))))) (return (let ((potential-form - (when (form-list-p first) - (form-before-in-children (children first) offset)))) + (cond ((form-list-p first) + (form-before-in-children (children first) offset)) + ((and (form-quoted-p first) + (not (form-incomplete-p first)) + (form-list-p (second (children first)))) + (form-before-in-children (children (second (children first))) offset))))) (if (not (null potential-form)) (if (<= (end-offset first) (end-offset potential-form)) --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/16 10:30:37 1.10 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/16 12:11:12 1.11 @@ -493,13 +493,14 @@ ;; nested/destructuring argument lists such as those found in ;; macros. (labels ((recurse (candidate-form) - (when (parent candidate-form) - (if (and (direct-arg-p syntax (first-form (children candidate-form)) - arg-form) - (not (find-applicable-form syntax (first-form (children candidate-form))))) - candidate-form + (if (and (direct-arg-p syntax (first-form (children candidate-form)) + arg-form) + (not (find-applicable-form syntax (first-form (children candidate-form))))) + candidate-form + (unless (form-at-top-level-p candidate-form) (recurse (parent candidate-form)))))) - (recurse (parent arg-form)))) + (unless (form-at-top-level-p arg-form) + (recurse (parent arg-form))))) (defun relevant-keywords (arglist arg-indices) "Return a list of the keyword arguments that it would make @@ -770,7 +771,8 @@ ;; If nothing else can be found, and `arg-form' ;; is the operator of its enclosing form, we use ;; the enclosing form. - (when (eq (first-form (children (parent immediate-form))) immediate-form) + (when (and (not (form-at-top-level-p immediate-form)) + (eq (first-form (children (parent immediate-form))) immediate-form)) (parent immediate-form)))))) ;; If we cannot find a form, there's no point in looking ;; up any of this stuff.