- climacs-cvs@common-lisp.net - mailman3.common-lisp.net

[climacs-cvs] CVS climacs
by thenriksen 03 Sep '06

03 Sep '06

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)

1 0

[climacs-cvs] CVS climacs
by thenriksen 02 Sep '06

02 Sep '06

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))

1 0

[climacs-cvs] CVS climacs
by thenriksen 02 Sep '06

02 Sep '06

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)))))

1 0

[climacs-cvs] CVS climacs
by thenriksen 02 Sep '06

02 Sep '06

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)))

1 0

[climacs-cvs] CVS climacs
by thenriksen 02 Sep '06

02 Sep '06

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?")

1 0

[climacs-cvs] CVS climacs
by thenriksen 01 Sep '06

01 Sep '06

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))

1 0

[climacs-cvs] CVS climacs
by thenriksen 31 Aug '06

31 Aug '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv13041 Modified Files: pane.lisp Log Message: Fixed updating-output bug and added simplistic handling of long lines (a band-aid, really). --- /project/climacs/cvsroot/climacs/pane.lisp 2006/08/20 13:06:38 1.49 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/08/31 18:40:48 1.50 @@ -368,7 +368,7 @@ (updating-output (pane :unique-id (incf id) :id-test #'= :cache-value contents - :cache-test #'string=) + :cache-test #'equal) (present-contents contents pane))) (setf saved-index nil)))) (with-slots (bot scan cursor-x cursor-y) pane @@ -561,11 +561,8 @@ (defgeneric fix-pane-viewport (pane)) (defmethod fix-pane-viewport ((pane climacs-pane)) - (let* ((v (window-viewport pane)) - (x (rectangle-width v)) - (y (rectangle-height v))) - (resize-sheet pane x y) - (setf (window-viewport-position pane) (values 0 0)))) + (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) @@ -582,9 +579,9 @@ (setf (full-redisplay-p pane) nil)) (adjust-cache pane)) (fill-cache pane) - (fix-pane-viewport pane) (update-syntax-for-display (buffer pane) (syntax (buffer pane)) (top pane) (bot pane)) - (redisplay-pane-with-syntax pane (syntax (buffer pane)) current-p)) + (redisplay-pane-with-syntax pane (syntax (buffer pane)) current-p) + (fix-pane-viewport pane)) (defgeneric full-redisplay (pane))

1 0

[climacs-cvs] CVS climacs
by thenriksen 30 Aug '06

30 Aug '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv29488 Modified Files: lisp-syntax-swine.lisp Log Message: Improved the capabilities of `define-form-traits' and added more form trait definitions. --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/08/28 17:22:58 1.2 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/08/30 19:32:23 1.3 @@ -325,6 +325,17 @@ (case (first operator) ('cl:lambda (cleanup-arglist (second operator))))) +;; HACK ALERT: SBCL, and some implementations I guess, provides us +;; with an arglist that is too simple, confusing the code +;; analysers. We fix that here. +(defmethod arglist-for-form (syntax (operator (eql 'clim-lisp:defclass)) &optional arguments) + (declare (ignore arguments)) + '(name (&rest superclasses) (&rest slots) &rest options)) + +(defmethod arglist-for-form (syntax (operator (eql 'cl:defclass)) &optional arguments) + (declare (ignore arguments)) + '(name (&rest superclasses) (&rest slots) &rest options)) + (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 @@ -520,109 +531,166 @@ relevant-completions)) completions)))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defgeneric code-for-argument-type-completion (argument-type syntax-symbol token-symbol all-completions-symbol) - (:documentation "Generate completion code for an argument of - type `argument-type'.") - (:method (argument-type syntax-symbol token-symbol all-completions-symbol) - '(call-next-method))) - - (defgeneric code-for-argument-list-modification (argument-type syntax-symbol arglist-symbol arguments-symbol) - (:documentation "Generate argument list modification code for - a form having an argument of type `argument-type'.") - (:method (argument-type syntax-symbol arglist-symbol arguments-symbol))) - - (defmacro define-argument-type (name (&optional inherit-from) - &rest options) - (let ((completion-code (rest (assoc :completion options))) - (modification-code (rest (assoc :arglist-modification options)))) - `(progn - ,(if (or completion-code inherit-from) - `(defmethod code-for-argument-type-completion ((argument-type (eql ',name)) - ,@(if completion-code - (first completion-code) - '(syntax token))) - ,(if completion-code - `'(let ((,(third (first completion-code)) - (call-next-method))) - ,@(rest completion-code)) - (code-for-argument-type-completion inherit-from 'syntax 'token 'all-completions))) - (let ((method (find-method #'code-for-argument-type-completion nil `((eql ,name) t t t) nil))) - (when method - (remove-method #'code-for-argument-type-completion method)))) - ,(if (or modification-code inherit-from) - `(defmethod code-for-argument-list-modification ((argument-type (eql ',name)) - ,@(if modification-code - (first modification-code) - '(syntax arglist arguments))) - ,(if modification-code - `'(progn ,@(rest modification-code)) - `',(code-for-argument-list-modification inherit-from 'syntax 'arglist 'arguments))) - (let ((method (find-method #'code-for-argument-list-modification nil `((eql ,name) t t t) nil))) - (when method - (remove-method #'code-for-argument-list-modification 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 (string-upcase completion))) - nil) - collect completion)) - (:arglist-modification (syntax arglist arguments) - (if (and (plusp (length arguments)) - (listp (first arguments)) - (> (length (first arguments)) 1) - (eq (caar arguments) 'cl:quote)) - (nconc arglist - (cons '&key (get-class-keyword-parameters - (get-usable-image syntax) - (first arguments))))))) - - (define-argument-type package-designator () - (:completion (syntax token all-completions) - (declare (ignore all-completions)) - (let* ((string (token-string syntax token)) - (keyworded (char= (aref string 0) #\:))) - (loop for package in (list-all-packages) - for package-name = (if keyworded - (concatenate 'string ":" (package-name package)) - (package-name package)) - when (search string package-name - :test #'char-equal - :end2 (min (length string) - (length package-name))) - collect (if (every #'upper-case-p string) - package-name - (string-downcase package-name))))))) - -(defmacro define-form-traits ((operator &rest arguments)) +(defgeneric complete-argument-of-type (argument-type syntax token all-completions) + (:documentation "") + (:method (argument-type syntax token all-completions) + all-completions)) + +(defgeneric modify-argument-list (argument-type syntax arglist arguments arg-position) + (:documentation "") + (:method (syntax argument-type arglist arguments arg-position) + arglist)) + +(defmacro define-argument-type (name (&optional inherit-from) + &rest options) + "Define an argument type for use in `define-form-traits'." + (let ((completion-code (rest (assoc :completion options))) + (modification-code (rest (assoc :arglist-modification options)))) + (assert (or (null completion-code) (= (length (first completion-code)) 3))) + (assert (or (null modification-code) (= (length (first modification-code)) 4))) + `(progn + ,(if (or completion-code inherit-from) + (let ((lambda-list (if completion-code + (first completion-code) + '(argument-type syntax token all-completions)))) + `(defmethod complete-argument-of-type ((argument-type (eql ',name)) + ,@lambda-list) + ,@(or (rest completion-code) + `((complete-argument-of-type ',inherit-from ,@lambda-list))))) + ;; If no completion rule has been specified for this + ;; type, we must check whether an earlier definition had + ;; completion rules - if so, remove the method + ;; implementing the rules. + `(let ((method (find-method #'complete-argument-of-type nil `((eql ,name) t t t) nil))) + (when method + (remove-method #'complete-argument-of-type method)))) + ,(if (or modification-code inherit-from) + (let ((lambda-list (if modification-code + (first modification-code) + '(syntax arglist arguments arg-position)))) + `(defmethod modify-argument-list ((argument-type (eql ',name)) + ,@lambda-list) + ,@(or (rest modification-code) + `((modify-argument-list ',inherit-from ,@lambda-list))))) + ;; If no arglist modification rule has been specified + ;; for this type, we must check whether an earlier + ;; definition had arglist modification rules - if so, + ;; remove the method implementing the rules. + `(let ((method (find-method #'modify-argument-list nil '((eql ,name) t t t t) nil))) + (when method + (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)) + (:arglist-modification (syntax arglist arguments arg-position) + (if (and (> (length arguments) arg-position) + (listp (elt arguments arg-position)) + (> (length (elt arguments arg-position)) 1) + (eq (first (elt arguments arg-position)) 'cl:quote) + (ignore-errors (find-class (second (elt arguments arg-position))))) + (nconc arglist + (cons '&key (get-class-keyword-parameters + (get-usable-image syntax) + (elt arguments arg-position)))) + arglist))) + +(define-argument-type package-designator () + (:completion (syntax token all-completions) + (declare (ignore all-completions)) + (let* ((string (token-string syntax token)) + (keyworded (char= (aref string 0) #\:))) + (loop for package in (list-all-packages) + for package-name = (if keyworded + (concatenate 'string ":" (package-name package)) + (package-name package)) + when (search string package-name + :test #'char-equal + :end2 (min (length string) + (length package-name))) + collect (if (every #'upper-case-p string) + package-name + (string-downcase package-name)))))) + +(defmacro define-form-traits ((operator &rest arguments) + &key no-typed-completion no-smart-arglist) + "Define \"traits\" for a form with the operator that is eql to +`operator'. Traits is a common designator for +intelligent (type-aware) completion and intelligent modification +of argument lists (for example, adding keyword arguments for the +initargs of the class being instantiated to the arglist of +`make-instance'). + +`Arguments' is a lambda-list-like list that describes the types +of the operands of `operator'. You can use the lambda-list +keywords `&rest' and `&key' to tie all, or specific keyword +arguments, to types. + +If `no-typed-completion' or `no-smart-arglist' is non-NIL, no +code for performing typed completion or smart arglist +modification will be generated, respectively." ;; FIXME: This macro should also define indentation rules. - (labels ((build-completions-codd-body (arguments) - (append (loop for argument in arguments - for i from 0 - collect `((and (= (first indices) ,i)) - ,(cond ((listp argument) - (if (eq (first argument) 'quote) - `(cond ((typep token 'quote-form) - ,(code-for-argument-type-completion (second argument) 'syntax 'token 'all-completions)) - (t (call-next-method))) - `(cond ((not (endp (rest indices))) - (pop indices) - (cond ,@(build-completions-codd-body argument))) - (t (call-next-method))))) - (t - (code-for-argument-type-completion argument 'syntax 'token 'all-completions))))) + (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. + `((t + (let* ((keyword (token-to-object syntax (form-before syntax (1- (start-offset token))))) + (type (getf ',arguments keyword))) + (if (null type) + (call-next-method) + (complete-argument-of-type type syntax token all-completions)))))) + (process-arg-descs (arguments index) + (let ((argument (first arguments))) + (cond ((null arguments) + nil) + ((eq argument '&rest) + `(((>= (first indices) ,index) + (complete-argument-of-type ',(second arguments) syntax token all-completions)))) + ((eq argument '&key) + (process-keyword-arg-descs (rest arguments))) + ((listp argument) + `(((= (first indices) ,index) + ,(if (eq (first argument) 'quote) + `(cond ((typep token 'quote-form) + (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))))))) + (t + (cons `((= (first indices) ,index) + (complete-argument-of-type ',argument syntax token 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) - (cond ,@(build-completions-codd-body arguments))) - (defmethod arglist-for-form (syntax (operator (eql ',operator)) &optional arguments) - (let ((arglist (call-next-method))) - ,@(mapcar #'(lambda (arg) - (code-for-argument-list-modification - (unlisted arg #'second) - 'syntax 'arglist 'arguments)) - arguments)))))) + ,(if no-typed-completion + '(call-next-method) + `(let ((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) + (declare (ignorable arguments)) + (let ((arglist (call-next-method)) + (arg-position 0)) + (declare (ignorable arg-position)) + ,@(loop for arg in arguments + collect `(setf arglist + (modify-argument-list + ',(unlisted arg #'second) + syntax arglist arguments arg-position)) + collect '(incf arg-position)) + arglist)))))) (defmacro with-code-insight (mark-or-offset syntax (&key operator preceding-operand form preceding-operand-indices @@ -670,15 +738,9 @@ (indices-match-arglist (arglist-for-form ,syntax-value-sym - (form-operator - form - ,syntax-value-sym) - (form-operands - form - ,syntax-value-sym)) - (second - (multiple-value-list - (find-operand-info ,mark-value-sym ,syntax-value-sym form)))) + (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)) @@ -699,9 +761,19 @@ ;;; Form trait definitions (define-form-traits (make-instance 'class-name)) +(define-form-traits (find-class 'class-name) + :no-smart-arglist t) +(define-form-traits (change-class t 'class-name)) (define-form-traits (make-pane 'class-name)) -(define-form-traits (find-class 'class-name)) +(define-form-traits (make-instances-obsolete 'class-name) + :no-smart-arglist t) +(define-form-traits (typep t 'class-name)) (define-form-traits (in-package package-designator)) +(define-form-traits (clim-lisp:defclass t (&rest class-name)) + :no-smart-arglist t) +(define-form-traits (cl:defclass t (&rest class-name)) + :no-smart-arglist t) +(define-form-traits (define-application-frame t (&rest class-name))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1026,7 +1098,7 @@ (t (when (and (needs-saving buffer) (accept 'boolean :prompt (format nil "Save buffer ~A ?" (name buffer)))) - (save-buffer buffer)) + (save-buffer buffer *application-frame*)) (let ((*read-base* (base (syntax buffer)))) (multiple-value-bind (result notes) (compile-file-for-climacs (get-usable-image (syntax buffer))

1 0

[climacs-cvs] CVS climacs
by thenriksen 28 Aug '06

28 Aug '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv4717 Modified Files: base.lisp lisp-syntax-swine.lisp lisp-syntax.lisp Log Message: Reversed the meaning of list arguments to `as-offsets' for unification with `let', `with-accessors', etc. --- /project/climacs/cvsroot/climacs/base.lisp 2006/08/20 13:06:39 1.58 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/08/28 17:22:58 1.59 @@ -37,14 +37,14 @@ "Bind the symbols in `marks' to the numeric offsets of the mark objects that the symbols are bound to. If a symbol in `mark' is already bound to an offset, just keep that binding. An element - of `marks' may also be a list - in this case, the first element - is used to get an offset, and the second element (which should - be a symbol) will be bound to this offset. Evaluate `body' with - these bindings." + of `marks' may also be a list - in this case, the second + element is used to get an offset, and the first element (which + should be a symbol) will be bound to this offset. Evaluate + `body' with these bindings." `(let ,(mapcar #'(lambda (mark-sym) (if (listp mark-sym) - `(,(second mark-sym) - (let ((value ,(first mark-sym))) + `(,(first mark-sym) + (let ((value ,(second mark-sym))) (if (numberp value) value (offset value)))) --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/08/20 13:10:31 1.1 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/08/28 17:22:58 1.2 @@ -361,7 +361,7 @@ (defun find-operand-info (mark-or-offset syntax operator-form) "Returns two values: The operand preceding `mark-or-offset' and the path from `operator-form' to the operand." - (as-offsets ((mark-or-offset offset)) + (as-offsets ((offset mark-or-offset)) (let* ((preceding-arg-token (form-before syntax offset)) (indexing-start-arg (let* ((candidate-before preceding-arg-token) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/08/20 13:10:31 1.109 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/08/28 17:22:58 1.110 @@ -1349,7 +1349,7 @@ found, return the package specified in the attribute list. If no package can be found at all, or the otherwise found packages are invalid, return the CLIM-USER package." - (as-offsets ((mark-or-offset offset)) + (as-offsets ((offset mark-or-offset)) (let* ((designator (rest (find offset (package-list syntax) :key #'first :test #'>=)))) @@ -1370,7 +1370,7 @@ package specified in that form does not exist. If no (in-package) form can be found, return the package specified in the attribute list. If no such package is specified, return \"CLIM-USER\"." - (as-offsets ((mark-or-offset offset)) + (as-offsets ((offset mark-or-offset)) (flet ((normalise (designator) (typecase designator (symbol @@ -1595,7 +1595,7 @@ `mark-or-offset', the form preceding `mark-or-offset' is returned. Otherwise, the form following `mark-or-offset' is returned." - (as-offsets ((mark-or-offset offset)) + (as-offsets ((offset mark-or-offset)) (or (form-around syntax offset) (form-after syntax offset) (form-before syntax offset)))) @@ -1640,13 +1640,13 @@ (defun this-form (mark-or-offset syntax) "Return a form at `mark-or-offset'. This function defines which forms the COM-FOO-this commands affect." - (as-offsets ((mark-or-offset offset)) + (as-offsets ((offset mark-or-offset)) (or (form-around syntax offset) (form-before syntax offset)))) (defun preceding-form (mark-or-offset syntax) "Return a form at `mark-or-offset'." - (as-offsets ((mark-or-offset offset)) + (as-offsets ((offset mark-or-offset)) (or (form-before syntax offset) (form-around syntax offset))))

1 0

[climacs-cvs] CVS climacs
by thenriksen 20 Aug '06

20 Aug '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv924 Modified Files: lisp-syntax.lisp lisp-syntax-swank.lisp lisp-syntax-commands.lisp Added Files: lisp-syntax-swine.lisp Log Message: Big refactoring and enhancement patch for Lisp syntax. * New file added, lisp-syntax-swine.lisp, in order to keep the size of lisp-syntax.lisp down. * `define-form-traits' macro that can be used to teach Climacs how to intelligently handle certain forms (for example, only symbols naming classes will be completed from when using `make-instance' or `make-pane'). * Taught Climacs how to handle certain forms. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/08/11 21:59:05 1.108 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/08/20 13:10:31 1.109 @@ -28,9 +28,9 @@ ;;; ;;; Convenience functions and macros: -(defun unlisted (obj) +(defun unlisted (obj &optional (fn #'first)) (if (listp obj) - (first obj) + (funcall fn obj) obj)) (defun listed (obj) @@ -614,57 +614,66 @@ (t (fo) (make-instance 'delimiter-lexeme))))) (defun lex-token (syntax scan) - ;; May need more work. Can recognize symbols and numbers. - (flet ((fo () (forward-object scan))) - (let ((could-be-number t) - sign-seen dot-seen slash-seen nondot-seen) - (flet ((return-token-or-number-lexeme () - (return-from lex-token - (if could-be-number - (if nondot-seen - (make-instance 'number-lexeme) - (make-instance 'dot-lexeme)) - (make-instance 'complete-token-lexeme)))) - (this-object () - (object-after scan))) - (tagbody - START + ;; May need more work. Can recognize symbols and numbers. This can + ;; get very ugly and complicated (out of necessity I believe). + (let ((could-be-number t) + sign-seen dot-seen slash-seen nondot-seen number-seen exponent-seen) + (flet ((fo () (forward-object scan)) + (return-token-or-number-lexeme () + (return-from lex-token + (if (and could-be-number + (if exponent-seen + nondot-seen t)) + (if nondot-seen + (make-instance 'number-lexeme) + (make-instance 'dot-lexeme)) + (make-instance 'complete-token-lexeme)))) + (this-object () + (object-after scan))) + (tagbody + START + (when (end-of-buffer-p scan) + (return-token-or-number-lexeme)) + (when (constituentp (object-after scan)) + (when (not (eql (this-object) #\.)) + (setf nondot-seen t)) + (cond ((or (eql (this-object) #\+) + (eql (this-object) #\-)) + (when (or sign-seen number-seen slash-seen) + (setf could-be-number nil)) + (setf sign-seen t)) + ((eql (this-object) #\.) + (when (or dot-seen exponent-seen) + (setf could-be-number nil)) + (setf dot-seen t)) + ((member (this-object) + '(#\e #\f #\l #\s #\d) + :test #'equalp) + (when exponent-seen + (setf could-be-number nil)) + (setf exponent-seen t) + (setf number-seen nil) + (setf sign-seen nil)) + ((eql (this-object) #\/) + (when (or slash-seen dot-seen exponent-seen) + (setf could-be-number nil)) + (setf slash-seen t)) + ((not (digit-char-p (this-object) + (base syntax))) + (setf could-be-number nil)) + (t (setf number-seen t))) + (fo) + (go START)) + (when (eql (object-after scan) #\\) + (fo) (when (end-of-buffer-p scan) - (return-token-or-number-lexeme)) - (when (constituentp (object-after scan)) - (when (not (eql (this-object) #\.)) - (setf nondot-seen t)) - (cond ((or (eql (this-object) #\+) - (eql (this-object) #\-)) - (when sign-seen - (setf could-be-number nil)) - (setf sign-seen t)) - ((eql (this-object) #\.) - (when dot-seen - (setf could-be-number nil)) - (setf dot-seen t)) - ((eql (this-object) #\/) - (when slash-seen - (setf could-be-number nil)) - (setf slash-seen t)) - ;; We obey the base specified in the file when - ;; determining whether or not this character is an - ;; integer. - ((not (digit-char-p (this-object) - (base syntax))) - (setf could-be-number nil))) - (fo) - (go START)) - (when (eql (object-after scan) #\\) - (fo) - (when (end-of-buffer-p scan) - (return-from lex-token (make-instance 'incomplete-lexeme))) - (fo) - (go START)) - (when (eql (object-after scan) #\|) - (fo) - (return-from lex-token (make-instance 'multiple-escape-start-lexeme))) - (return-token-or-number-lexeme)))))) + (return-from lex-token (make-instance 'incomplete-lexeme))) + (fo) + (go START)) + (when (eql (object-after scan) #\|) + (fo) + (return-from lex-token (make-instance 'multiple-escape-start-lexeme))) + (return-token-or-number-lexeme))))) (defmethod lex ((syntax lisp-syntax) (state lexer-escaped-token-state) scan) (let ((bars-seen 0)) @@ -1380,7 +1389,7 @@ (defmacro with-syntax-package ((syntax offset) &body body) "Evaluate `body' with `*package*' bound to a valid package, - preferably taken from `syntax' based on `offset'.." + preferably taken from `syntax' based on `offset'." `(let ((*package* (package-at-mark ,syntax ,offset))) ,@body)) @@ -1555,10 +1564,9 @@ (:method (form syntax) nil)) (defmethod form-operands ((form list-form) syntax) - (mapcar #'(lambda (operand) - (if (typep operand 'form) - (token-to-object syntax operand :no-error t))) - (rest-forms (children form)))) + (loop for operand in (rest-forms (children form)) + when (typep operand 'form) + collect (token-to-object syntax operand :no-error t))) (defun form-toplevel (form syntax) "Return the top-level form of `form'." @@ -1588,9 +1596,9 @@ returned. Otherwise, the form following `mark-or-offset' is returned." (as-offsets ((mark-or-offset offset)) - (or (form-around syntax offset) - (form-after syntax offset) - (form-before syntax offset)))) + (or (form-around syntax offset) + (form-after syntax offset) + (form-before syntax offset)))) (defun definition-at-mark (mark-or-offset syntax) "Return the top-level form at `mark-or-offset'. If `mark-or-offset' is just after, @@ -1611,6 +1619,24 @@ form)))) (unwrap-form (expression-at-mark mark-or-offset syntax)))) +(defun fully-quoted-form (token) + "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) + (ascend (parent form))) + (t form)))) + (ascend token))) + +(defun fully-unquoted-form (token) + "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) + (descend (first-form (children form)))) + (t form)))) + (descend token))) + (defun this-form (mark-or-offset syntax) "Return a form at `mark-or-offset'. This function defines which forms the COM-FOO-this commands affect." @@ -2597,7 +2623,7 @@ (if (null (cdr path)) ;; top level (let* ((arglist (when (fboundp symbol) - (arglist-for-form symbol))) + (arglist-for-form syntax symbol))) (body-or-rest-pos (or (position '&body arglist) (position '&rest arglist)))) (if (and (or (macro-function symbol) @@ -2609,7 +2635,7 @@ ;; &body arg. (values (elt-noncomment (children tree) 1) 1) ;; non-&body-arg. - (values (elt-noncomment (children tree) 1) 3)) + (values (elt-noncomment (children tree) 1) 1)) ;; normal form. (if (= (car path) 2) ;; indent like first child @@ -2867,1222 +2893,3 @@ (defmethod uncomment-region ((syntax lisp-syntax) mark1 mark2) (line-uncomment-region syntax mark1 mark2)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Swine - -;;; Compiler note hyperlinking code - -(defun make-compiler-note (note-list) - (let ((severity (getf note-list :severity)) - (message (getf note-list :message)) - (location (getf note-list :location)) - (references (getf note-list :references)) - (short-message (getf note-list :short-message))) - (make-instance - (ecase severity - (:error 'error-compiler-note) - (:read-error 'read-error-compiler-note) - (:warning 'warning-compiler-note) - (:style-warning 'style-warning-compiler-note) - (:note 'note-compiler-note)) - :message message :location location - :references references :short-message short-message))) - -(defclass compiler-note () - ((message :initarg :message :initform nil :accessor message) - (location :initarg :location :initform nil :accessor location) - (references :initarg :references :initform nil :accessor references) - (short-message :initarg :short-message :initform nil :accessor short-message)) - (:documentation "The base for all compiler-notes.")) - -(defclass error-compiler-note (compiler-note) ()) - -(defclass read-error-compiler-note (compiler-note) ()) - -(defclass warning-compiler-note (compiler-note) ()) - -(defclass style-warning-compiler-note (compiler-note) ()) - -(defclass note-compiler-note (compiler-note) ()) - -(defclass location ()() - (:documentation "The base for all locations.")) - -(defclass error-location (location) - ((error-message :initarg :error-message :accessor error-message))) - -(defclass actual-location (location) - ((source-position :initarg :position :accessor source-position) - (snippet :initarg :snippet :accessor snippet :initform nil)) - (:documentation "The base for all non-error locations.")) - -(defclass buffer-location (actual-location) - ((buffer-name :initarg :buffer :accessor buffer-name))) - -(defclass file-location (actual-location) - ((file-name :initarg :file :accessor file-name))) - -(defclass source-location (actual-location) - ((source-form :initarg :source-form :accessor source-form))) - -(defclass basic-position () () - (:documentation "The base for all positions.")) - -(defclass char-position (basic-position) - ((char-position :initarg :position :accessor char-position) - (align-p :initarg :align-p :initform nil :accessor align-p))) - -(defun make-char-position (position-list) - (make-instance 'char-position :position (second position-list) - :align-p (third position-list))) - -(defclass line-position (basic-position) - ((start-line :initarg :line :accessor start-line) - (end-line :initarg :end-line :initform nil :accessor end-line))) - -(defun make-line-position (position-list) - (make-instance 'line-position :line (second position-list) - :end-line (third position-list))) - -(defclass function-name-position (basic-position) - ((function-name :initarg :function-name))) - -(defun make-function-name-position (position-list) - (make-instance 'function-name-position :function-name (second position-list))) - -(defclass source-path-position (basic-position) - ((path :initarg :source-path :accessor path) - (start-position :initarg :start-position :accessor start-position))) - -(defun make-source-path-position (position-list) - (make-instance 'source-path-position :source-path (second position-list) - :start-position (third position-list))) - -(defclass text-anchored-position (basic-position) - ((start :initarg :text-anchored :accessor start) - (text :initarg :text :accessor text) - (delta :initarg :delta :accessor delta))) - -(defun make-text-anchored-position (position-list) - (make-instance 'text-anchored-position :text-anchored (second position-list) - :text (third position-list) - :delta (fourth position-list))) - -(defclass method-position (basic-position) - ((name :initarg :method :accessor name) - (specializers :initarg :specializers :accessor specializers) - (qualifiers :initarg :qualifiers :accessor qualifiers))) - -(defun make-method-position (position-list) - (make-instance 'method-position :method (second position-list) - :specializers (third position-list) - :qualifiers (last position-list))) - -(defun make-location (location-list) - (ecase (first location-list) - (:error (make-instance 'error-location :error-message (second location-list))) - (:location - (destructuring-bind (l buf pos hints) location-list - (declare (ignore l)) - (let ((location - (apply #'make-instance - (ecase (first buf) - (:file 'file-location) - (:buffer 'buffer-location) - (:source-form 'source-location)) - buf)) - (position - (funcall - (ecase (first pos) - (:position #'make-char-position) - (:line #'make-line-position) - (:function-name #'make-function-name-position) - (:source-path #'make-source-path-position) - (:text-anchored #'make-text-anchored-position) - (:method #'make-method-position)) - pos))) - (setf (source-position location) position) - (when hints - (setf (snippet location) (rest hints))) - location))))) - -(defmethod initialize-instance :after ((note compiler-note) &rest args) - (declare (ignore args)) - (setf (location note) (make-location (location note)))) - -(defun show-note-counts (notes &optional seconds) - (loop with nerrors = 0 - with nwarnings = 0 - with nstyle-warnings = 0 - with nnotes = 0 - for note in notes - do (etypecase note - (error-compiler-note (incf nerrors)) - (read-error-compiler-note (incf nerrors)) - (warning-compiler-note (incf nwarnings)) - (style-warning-compiler-note (incf nstyle-warnings)) - (note-compiler-note (incf nnotes))) - finally - (esa:display-message "Compilation finished: ~D error~:P ~ - ~D warning~:P ~D style-warning~:P ~D note~:P ~ - ~@[[~D secs]~]" - nerrors nwarnings nstyle-warnings nnotes seconds))) - -(defun one-line-ify (string) - "Return a single-line version of STRING. -Each newline and following whitespace is replaced by a single space." - (loop with count = 0 - while (< count (length string)) - with new-string = (make-array 0 :element-type 'character :adjustable t - :fill-pointer 0) - when (char= (char string count) #\Newline) - do (loop while (and (< count (length string)) - (whitespacep nil (char string count))) - do (incf count) - ;; Just ignore whitespace if it is last in the - ;; string. - finally (when (< count (length string)) - (vector-push-extend #\Space new-string))) - else - do (vector-push-extend (char string count) new-string) - (incf count) - finally (return new-string))) - -(defgeneric print-for-menu (object stream)) - -(defun print-note-for-menu (note stream severity ink) [1033 lines skipped] --- /project/climacs/cvsroot/climacs/lisp-syntax-swank.lisp 2006/07/05 13:52:17 1.1 +++ /project/climacs/cvsroot/climacs/lisp-syntax-swank.lisp 2006/08/20 13:10:31 1.2 @@ -47,7 +47,7 @@ (handler-case (asdf:oos 'asdf:load-op :swank) (asdf:missing-component () (esa:display-message "Swank not available."))))) - (setf (image (syntax (current-buffer))) + (setf (image (syntax (current-buffer *application-frame*))) (make-instance 'swank-local-image))) (defmethod compile-string-for-climacs ((image swank-local-image) string package buffer buffer-mark) --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/08/11 21:59:05 1.15 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/08/20 13:10:31 1.16 @@ -88,13 +88,13 @@ (define-command (com-set-base :name t :command-table lisp-table) ((base '(integer 2 36))) "Set the base for the current buffer." - (setf (base (syntax (current-buffer))) + (setf (base (syntax (current-buffer *application-frame*))) base)) (define-command (com-set-package :name t :command-table lisp-table) ((package 'package)) "Set the package for the current buffer." - (setf (option-specified-package (syntax (current-buffer))) + (setf (option-specified-package (syntax (current-buffer *application-frame*))) package)) (define-command (com-indent-expression :name t :command-table lisp-table) --- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/08/20 13:10:31 NONE +++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/08/20 13:10:31 1.1 ;;; -*- Mode: Lisp; Package: CLIMACS-LISP-SYNTAX -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh(a)labri.fr) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Functionality designed to aid development of Common Lisp code. (in-package :climacs-lisp-syntax) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Code interrogation/form analysis (defparameter +cl-arglist-keywords+ lambda-list-keywords) (defparameter +cl-garbage-keywords+ '(&whole &environment)) (defun arglist-keyword-p (arg) "Return T if `arg' is an arglist keyword. NIL otherwise." (when (member arg +cl-arglist-keywords+) t)) (defun split-arglist-on-keywords (arglist) "Return an alist keying lambda list keywords of `arglist' to the symbols affected by the keywords." (let ((sing-result '()) (env (position '&environment arglist))) (when env (push (list '&environment (elt arglist (1+ env))) sing-result) (setf arglist (remove-if (constantly t) arglist :start env :end (+ env 2)))) (when (eq '&whole (first arglist)) (push (subseq arglist 0 2) sing-result) (setf arglist (cddr arglist))) (do ((llk '(&mandatory &optional &key &allow-other-keys &aux &rest &body)) (args (if (arglist-keyword-p (first arglist)) arglist (cons '&mandatory arglist)) (cdr args)) (chunk '()) (result '())) ((null args) (when chunk (push (nreverse chunk) result)) (nreverse (nconc sing-result result))) (if (member (car args) llk) (progn (when chunk (push (nreverse chunk) result)) (setf chunk (list (car args)))) (push (car args) chunk))))) (defun find-optional-argument-values (arglist provided-args &optional (split-arglist (split-arglist-on-keywords arglist))) "Return an association list mapping symbols of optional or keyword arguments from `arglist' to the specified values in `provided-args'. `Split-arglist' should be either a split arglist or nil, in which case it will be calculated from `arglist'." (flet ((get-args (keyword) (rest (assoc keyword split-arglist)))) (let* ((mandatory-args-count (length (get-args '&mandatory))) (optional-args-count (length (get-args '&optional))) (keyword-args-count (length (get-args '&key))) (provided-args-count (length provided-args)) (nonmandatory-args-count (+ keyword-args-count optional-args-count))) ;; First we check whether any optional arguments have even been ;; provided. (when (> provided-args-count mandatory-args-count) ;; We have optional arguments. (let ( ;; Find the part of the provided arguments that concern ;; optional arguments. (opt-args-values (subseq provided-args mandatory-args-count (min provided-args-count nonmandatory-args-count))) ;; Find the part of the provided arguments that concern ;; keyword arguments. (keyword-args-values (subseq provided-args (min (+ mandatory-args-count optional-args-count) provided-args-count)))) (append (mapcar #'cons (mapcar #'unlisted (get-args '&optional)) opt-args-values) (loop ;; Loop over the provided keyword symbols and ;; values in the argument list. Note that ;; little checking is done to ensure that the ;; given symbols are valid - this is not a ;; compiler, so extra mappings do not ;; matter. for (keyword value) on keyword-args-values by #'cddr if (keywordp keyword) collect (let ((argument-symbol (unlisted (find (symbol-name keyword) (get-args '&key) :key #'(lambda (arg) (symbol-name (unlisted arg))) :test #'string=)))) ;; We have to find the associated ;; symbol in the argument list... ugly. (cons argument-symbol value))))))))) (defun find-affected-simple-arguments (arglist current-arg-index preceding-arg &optional (split-arglist (split-arglist-on-keywords arglist))) "Find the simple arguments of `arglist' that would be affected if an argument was intered at index `current-arg-index' in the arglist. If `current-arg-index' is nil, no calculation will be done (this function will just return nil). `Preceding-arg' should either be nil or the argument directly preceding point. `Split-arglist' should either be a split arglist or nil, in which case `split-arglist' will be computed from `arglist'. This function returns two values: The primary value is a list of symbols that should be emphasized, the secondary value is a list of symbols that should be highlighted." (when current-arg-index (flet ((get-args (keyword) (rest (assoc keyword split-arglist)))) (let ((mandatory-argument-count (length (get-args '&mandatory)))) (cond ((> mandatory-argument-count current-arg-index) ;; We are in the main, mandatory, positional arguments. (let ((relevant-arg (elt (get-args '&mandatory) current-arg-index))) ;; We do not handle complex argument lists here, only ;; pure standard arguments. (unless (and (listp relevant-arg) (< current-arg-index mandatory-argument-count)) (values nil (list (unlisted relevant-arg)))))) ((> (+ (length (get-args '&optional)) (length (get-args '&mandatory))) current-arg-index) ;; We are in the &optional arguments. (values nil (list (unlisted (elt (get-args '&optional) (- current-arg-index (length (get-args '&mandatory)))))))) (t (let ((body-or-rest-args (or (get-args '&rest) (get-args '&body))) (key-arg (find (format nil "~A" preceding-arg) (get-args '&key) :test #'string= :key #'(lambda (arg) (symbol-name (unlisted arg)))))) ;; We are in the &body, &rest or &key arguments. (values ;; Only emphasize the &key ;; symbol if we are in a position to add a new ;; keyword-value pair, and not just in a position to ;; specify a value for a keyword. (when (and (null key-arg) (get-args '&key)) '(&key)) (append (when key-arg (list (unlisted key-arg))) body-or-rest-args))))))))) (defun analyze-arglist-impl (arglist current-arg-indices preceding-arg provided-args) "The implementation for `analyze-arglist'." (let* ((split-arglist (split-arglist-on-keywords arglist)) (user-supplied-arg-values (find-optional-argument-values arglist provided-args split-arglist)) (mandatory-argument-count (length (rest (assoc '&mandatory split-arglist)))) (current-arg-index (or (first current-arg-indices) 0)) ret-arglist emphasized-symbols highlighted-symbols) ;; First, we find any standard arguments that should be ;; highlighted or emphasized, more complex, destructuring ;; arguments will be handled specially. (multiple-value-bind (es hs) (find-affected-simple-arguments arglist ;; If `current-arg-indices' is ;; nil, that means that we do ;; not have enough information ;; to properly highlight ;; symbols in the arglist. (and current-arg-indices current-arg-index) preceding-arg split-arglist) (setf emphasized-symbols es) (setf highlighted-symbols hs)) ;; We loop over the arglist and build a new list, and if we have a ;; default value for a given argument, we insert it into the ;; list. Also, whenever we encounter a list in a mandatory ;; argument position, we assume that it is a destructuring arglist ;; and recursively call `analyze-arglist' on it to find the ;; arglist and emphasized and highlighted symbols for it. (labels ((generate-arglist (arglist) (loop for arg-element in arglist for arg-name = (unlisted arg-element) for index from 0 if (and (listp arg-element) (> mandatory-argument-count index)) collect (multiple-value-bind (arglist sublist-emphasized-symbols sublist-highlighted-symbols) (analyze-arglist arg-element (rest current-arg-indices) preceding-arg (when (< index (length provided-args)) (listed (elt provided-args index)))) ;; Unless our `current-arg-index' ;; actually refers to this sublist, its ;; highlighted and emphasized symbols ;; are ignored. Also, if ;; `current-arg-indices' is nil, we do ;; not have enough information to ;; properly highlight symbols in the ;; arglist. (when (and current-arg-indices (= index current-arg-index)) (if (and (rest current-arg-indices)) (setf emphasized-symbols (union (mapcar #'unlisted sublist-emphasized-symbols) emphasized-symbols) highlighted-symbols (union sublist-highlighted-symbols highlighted-symbols)) (setf emphasized-symbols (union (mapcar #'unlisted arg-element) emphasized-symbols)))) arglist) else if (assoc arg-name user-supplied-arg-values) collect (list arg-name (rest (assoc arg-name user-supplied-arg-values))) else collect arg-element))) (setf ret-arglist (generate-arglist arglist))) (list ret-arglist emphasized-symbols highlighted-symbols))) (defun analyze-arglist (arglist current-arg-indices preceding-arg provided-args) "Analyze argument list and provide information for highlighting it. `Arglist' is the argument list that is to be analyzed, `current-arg-index' is the index where the next argument would be written (0 is just after the operator), `preceding-arg' is the written argument preceding point and `provided-args' is a list of the args already written. Three values are returned: * An argument list with values for &optional and &key arguments inserted from `provided-args'. * A list of symbols that should be emphasized. * A list of symbols that should be highlighted." (apply #'values (analyze-arglist-impl arglist current-arg-indices preceding-arg provided-args))) (defun cleanup-arglist (arglist) "Remove elements of `arglist' that we are not interested in." (loop for arg in arglist with in-&aux ; If non-NIL, we are in the ; &aux parameters that should ; not be displayed. with in-garbage ; If non-NIL, the next ; argument is a garbage ; parameter that should not be ; displayed. if in-garbage do (setf in-garbage nil) else if (not in-&aux) if (eq arg '&aux) do (setf in-&aux t) else if (member arg +cl-garbage-keywords+ :test #'eq) do (setf in-garbage t) else collect arg)) (defgeneric arglist-for-form (syntax operator &optional arguments) (:documentation "Return an arglist for `operator'") (:method (syntax operator &optional arguments) (declare (ignore arguments)) (cleanup-arglist (arglist (get-usable-image syntax) operator)))) (defmethod arglist-for-form (syntax (operator list) &optional arguments) (declare (ignore arguments)) (case (first operator) ('cl:lambda (cleanup-arglist (second operator))))) (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). " (declare (ignore syntax)) (let ((operator (first-form (children operator-form)))) (labels ((worker (operand-form &optional the-first) ;; Cannot find index for top-level-form. (when (parent operand-form) (let ((form-operand-list (remove-if #'(lambda (form) (or (not (typep form 'form)) (eq form operator))) (children (parent operand-form))))) (let ((operand-position (position operand-form form-operand-list)) (go-on (not (eq operator-form (parent operand-form))))) ;; If we find anything, we have to increment the ;; position by 1, since we consider the existance ;; of a first operand to mean point is at operand ;; 2. Likewise, a position of nil is interpreted ;; as 0. (cons (if operand-position (if (or the-first) (1+ operand-position) operand-position) 0) (when go-on (worker (parent operand-form))))))))) (nreverse (worker operand-form t))))) (defun find-operand-info (mark-or-offset syntax operator-form) "Returns two values: The operand preceding `mark-or-offset' and the path from `operator-form' to the operand." (as-offsets ((mark-or-offset offset)) (let* ((preceding-arg-token (form-before syntax offset)) (indexing-start-arg (let* ((candidate-before preceding-arg-token) (candidate-after (when (null candidate-before) (let ((after (form-after syntax offset))) (when after (parent after))))) (candidate-around (when (null candidate-after) (form-around syntax offset))) (candidate (or candidate-before candidate-after candidate-around))) (if (or (and candidate-before (typep candidate-before 'incomplete-list-form)) (and (null candidate-before) (typep (or candidate-after candidate-around) 'list-form))) ;; HACK: We should not attempt to find the location of [971 lines skipped]

1 0