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

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 03 Jan '08

03 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11398/Drei Modified Files: fundamental-syntax.lisp Log Message: Fixed reparsing bug in Fundamental syntax. Because chunk offsets were absolute, and not relative to the line start mark, line information became out of date when changes were made to previous lines. --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/03 12:32:08 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/03 16:25:16 1.10 @@ -59,37 +59,50 @@ (%chunks :accessor chunks :initform (make-array 5 :adjustable t - :fill-pointer 0)))) + :fill-pointer 0) + :documentation "A list of cons-cells, with the car +being a buffer offset relative to the `start-mark' of the line, +and the cdr being T if the chunk covers a non-character, and NIL +if it covers a character sequence."))) (defun line-end-offset (line) "Return the end buffer offset of `line'." (+ (offset (start-mark line)) (line-length line))) -(defun get-chunk (buffer chunk-start-offset line-end-offset) +(defun get-chunk (buffer line-start-offset chunk-start-offset line-end-offset) + "Return a chunk in the form of a cons cell. The chunk will +start at `chunk-start-offset' and extend no further than +`line-end-offset'." (let* ((chunk-end-offset (buffer-find-nonchar buffer chunk-start-offset (min (+ *maximum-chunk-size* chunk-start-offset) line-end-offset)))) (cond ((= chunk-start-offset line-end-offset) - (cons chunk-end-offset nil)) + (cons (- chunk-end-offset + line-start-offset) nil)) ((or (not (= chunk-end-offset chunk-start-offset)) (and (offset-beginning-of-line-p buffer chunk-start-offset) (offset-end-of-line-p buffer chunk-end-offset))) - (cons chunk-end-offset nil)) + (cons (- chunk-end-offset + line-start-offset) nil)) ((not (characterp (buffer-object buffer chunk-end-offset))) - (cons (1+ chunk-end-offset) t))))) + (cons (- (1+ chunk-end-offset) + line-start-offset) t))))) (defmethod initialize-instance :after ((line line-object) &rest initargs) (declare (ignore initargs)) (loop with buffer = (buffer (start-mark line)) - with chunk-start-offset = (offset (start-mark line)) - with line-end-offset = (end-of-line-offset buffer (offset (start-mark line))) - for chunk-info = (get-chunk (buffer (start-mark line)) + with line-start-offset = (offset (start-mark line)) + with line-end-offset = (+ line-start-offset (line-length line)) + with chunk-start-offset = line-start-offset + for chunk-info = (get-chunk buffer + line-start-offset chunk-start-offset line-end-offset) do (vector-push-extend chunk-info (chunks line)) - (setf chunk-start-offset (car chunk-info)) + (setf chunk-start-offset (+ (car chunk-info) + line-start-offset)) when (= chunk-start-offset line-end-offset) do (loop-finish))) @@ -168,11 +181,13 @@ (defun fetch-chunk (line chunk-index) "Retrieve the `chunk-index'th chunk from `line'. The return value is either an integer, in which case it specifies the -end-offset of a string chunk, or a function, in which case it is -the drawing function for a single-object non-character chunk." - (destructuring-bind (chunk-end-offset . objectp) +end-offset of a string chunk relative to the start of the line, +or a function, in which case it is the drawing function for a +single-object non-character chunk." + (destructuring-bind (relative-chunk-end-offset . objectp) (aref (chunks line) chunk-index) - (if objectp (object-drawer) chunk-end-offset))) + (if objectp (object-drawer) (+ relative-chunk-end-offset + (offset (start-mark line)))))) (defmethod stroke-pump-with-syntax ((view textual-drei-syntax-view) (syntax fundamental-syntax) stroke

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 03 Jan '08

03 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv10630/Drei Modified Files: views.lisp Log Message: Buffer-views no longer responsible for updating syntax-view data. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/02 14:43:40 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/03 16:21:20 1.11 @@ -555,16 +555,10 @@ (defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) changed-region) - (with-accessors ((prefix-size prefix-size) - (suffix-size suffix-size)) view - (setf prefix-size (min (car changed-region) prefix-size) - suffix-size (min (- (size buffer) (cdr changed-region)) - suffix-size) - (modified-p view) t) - (dotimes (i (displayed-lines-count view)) - (let ((line (line-information view i))) - (when (<= (car changed-region) (line-end-offset line)) - (invalidate-line-strokes line :modified t)))))) + (dotimes (i (displayed-lines-count view)) + (let ((line (line-information view i))) + (when (<= (car changed-region) (line-end-offset line)) + (invalidate-line-strokes line :modified t))))) (defclass drei-syntax-view (drei-buffer-view) ((%syntax :accessor syntax) @@ -651,6 +645,16 @@ (disable-mode (syntax modual) mode-name) (call-next-method))) +(defmethod observer-notified ((view drei-syntax-view) (buffer drei-buffer) + changed-region) + (with-accessors ((prefix-size prefix-size) + (suffix-size suffix-size)) view + (setf prefix-size (min (car changed-region) prefix-size) + suffix-size (min (- (size buffer) (cdr changed-region)) + suffix-size) + (modified-p view) t)) + (call-next-method)) + (defmethod synchronize-view :around ((view drei-syntax-view) &key force-p) ;; If nothing changed, then don't call the other methods. @@ -672,8 +676,7 @@ (setf (prefix-size view) (size (buffer view)) (suffix-size view) (size (buffer view)) (buffer-size view) (size (buffer view))) - (update-syntax (syntax view) prefix-size suffix-size - begin end) + (update-syntax (syntax view) prefix-size suffix-size begin end) (call-next-method))) (defun make-syntax-for-view (view syntax-symbol &rest args)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 03 Jan '08

03 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8313/Drei Modified Files: buffer.lisp Log Message: Added print-object method for buffers. --- /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2008/01/01 18:43:36 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2008/01/03 16:19:42 1.7 @@ -690,3 +690,11 @@ (defmethod (setf buffer-object) :after (object (buffer observable-buffer-mixin) offset) (notify-observers buffer (constantly (cons offset (1+ offset))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Print method for ease of debugging + +(defmethod print-object ((object buffer) stream) + (print-unreadable-object (object stream :type t :identity t) + (format stream "size:~A" (size object))))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 03 Jan '08

03 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv3433/Drei Modified Files: fundamental-syntax.lisp lisp-syntax.lisp lr-syntax.lisp packages.lisp Log Message: Added syntax highlighting of Lisp syntax. Yay! Doesn't highlight fully as much as it used to, as it's slightly more complicated to get fast enough. Also, not terribly heavily optimized. --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/02 14:43:40 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/03 12:32:08 1.9 @@ -54,11 +54,17 @@ (defclass line-object () ((%start-mark :reader start-mark :initarg :start-mark) + (%line-length :reader line-length + :initarg :line-length) (%chunks :accessor chunks :initform (make-array 5 :adjustable t :fill-pointer 0)))) +(defun line-end-offset (line) + "Return the end buffer offset of `line'." + (+ (offset (start-mark line)) (line-length line))) + (defun get-chunk (buffer chunk-start-offset line-end-offset) (let* ((chunk-end-offset (buffer-find-nonchar buffer chunk-start-offset @@ -116,14 +122,16 @@ (setf (offset scan) (offset low-mark)) (loop while (mark<= scan high-mark) for i from low-index - do (progn (insert* lines i (make-instance - 'line-object - :start-mark (clone-mark scan))) - (end-of-line scan) - (if (end-of-buffer-p scan) - (loop-finish) - ;; skip newline - (forward-object scan))))))))) + do (progn (let ((line-start-mark (clone-mark scan))) + (insert* lines i (make-instance + 'line-object + :start-mark line-start-mark + :line-length (- (offset (end-of-line scan)) + (offset line-start-mark)))) + (if (end-of-buffer-p scan) + (loop-finish) + ;; skip newline + (forward-object scan)))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -195,7 +203,32 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; exploit the parse +;;; exploit the parse + +(defun offset-in-line-p (line offset) + "Return true if `offset' is in the buffer region delimited by +`line'." + (<= (offset (start-mark line)) offset + (line-end-offset line))) + +(defun line-containing-offset (syntax mark-or-offset) + "Return the line `mark-or-offset' is in for `syntax'. `Syntax' +must be a `fundamental-syntax' object." + ;; Perform binary search looking for line containing `offset1'. + (as-offsets ((offset mark-or-offset)) + (with-accessors ((lines lines)) syntax + (loop with low-index = 0 + with high-index = (nb-elements lines) + for middle = (floor (+ low-index high-index) 2) + for this-line = (element* lines middle) + for line-start = (start-mark this-line) + do (cond ((offset-in-line-p this-line offset) + (loop-finish)) + ((mark> offset line-start) + (setf low-index (1+ middle))) + ((mark< offset line-start) + (setf high-index middle))) + finally (return this-line))))) ;; do this better (defmethod syntax-line-indentation ((syntax fundamental-syntax) mark tab-width) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/02 14:21:06 1.44 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/03 12:32:08 1.45 @@ -147,6 +147,9 @@ (or (image syntax) (default-image)))) +(defconstant +keyword-package+ (find-package :keyword) + "The KEYWORD package.") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Swank interface functions. @@ -1479,6 +1482,39 @@ (or (typep (parent form) 'form*) (null (parent form))))) +(defgeneric eval-feature-conditional (conditional-form syntax)) + +(defmethod eval-feature-conditional (conditional-form (syntax lisp-syntax)) + nil) + +;; Adapted from slime.el + +(defmethod eval-feature-conditional ((conditional token-mixin) (syntax lisp-syntax)) + (let* ((string (form-string syntax conditional)) + (symbol (parse-symbol string :package +keyword-package+))) + (member symbol *features*))) + +(defmethod eval-feature-conditional ((conditional list-form) (syntax lisp-syntax)) + (let ((children (children conditional))) + (when (third-noncomment children) + (flet ((eval-fc (conditional) + (funcall #'eval-feature-conditional conditional syntax))) + (let* ((type (second-noncomment children)) + (conditionals (butlast + (nthcdr + 2 + (remove-if + #'comment-p + children)))) + (type-string (form-string syntax type)) + (type-symbol (parse-symbol type-string :package +keyword-package+))) + (case type-symbol + (:and (funcall #'every #'eval-fc conditionals)) + (:or (funcall #'some #'eval-fc conditionals)) + (:not (when conditionals + (funcall #'(lambda (f l) (not (apply f l))) + #'eval-fc conditionals))))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Asking about parse state at some point @@ -1731,242 +1767,22 @@ ;;; ;;; display -(defparameter *reader-conditional-faces* - (list (make-face :error +red+) - (make-face :string +gray50+ (make-text-style nil :italic nil)) - (make-face :keyword +gray50+) - (make-face :macro +gray50+) - (make-face :special-form +gray50+) - (make-face :lambda-list-keyword +gray50+) - (make-face :comment +gray50+) - (make-face :reader-conditional +gray50+))) - -(define-standard-faces lisp-syntax - (make-face :error +red+) - (make-face :string +rosy-brown+ (make-text-style nil :italic nil)) - (make-face :keyword +orchid+) - (make-face :macro +purple+) - (make-face :special-form +purple+) - (make-face :lambda-list-keyword +dark-green+) - (make-face :comment +maroon+) - (make-face :reader-conditional +gray50+)) - -(defmethod display-parse-tree ((parse-symbol (eql nil)) stream (view textual-drei-syntax-view) - (syntax lisp-syntax)) - nil) - -(defmethod display-parse-tree ((parse-symbol error-symbol) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let ((children (children parse-symbol))) - (loop until (or (null (cdr children)) - (typep (parser-state (cadr children)) 'error-state)) - do (display-parse-tree (pop children) stream view syntax)) - (if (and (null (cdr children)) - (not (typep (parser-state parse-symbol) 'error-state))) - (display-parse-tree (car children) stream view syntax) - (with-face (:error) - (loop for child in children - do (display-parse-tree child stream view syntax)))))) - -(defmethod display-parse-tree ((parse-symbol error-lexeme) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (with-face (:error) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol unmatched-right-parenthesis-lexeme) - stream (view textual-drei-syntax-view) (syntax lisp-syntax)) - (with-face (:error) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol token-mixin) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (if (> (the fixnum (end-offset parse-symbol)) (the fixnum (start-offset parse-symbol))) - (let ((symbol (form-to-object syntax parse-symbol :no-error t))) - (with-output-as-presentation (stream symbol 'symbol :single-box :highlighting) - (cond ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\:) - (with-face (:keyword) - (call-next-method))) - ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\&) - (with-face (:lambda-list-keyword) - (call-next-method))) - ((and (symbolp symbol) - (macro-function symbol) - (form-operator-p syntax parse-symbol)) - (with-face (:macro) - (call-next-method))) - ((and (symbolp symbol) - (special-operator-p symbol) - (form-operator-p syntax parse-symbol)) - (with-face (:special-form) - (call-next-method))) - (t (call-next-method))))) - (call-next-method))) - -(defmethod display-parse-tree ((parser-symbol literal-object-form) stream (view textual-drei-syntax-view) - (syntax lisp-syntax)) - (updating-output - (stream :unique-id (list view parser-symbol) - :id-test #'equal - :cache-value parser-symbol - :cache-test #'eql) - (let ((object (form-to-object syntax parser-symbol))) - (present object (presentation-type-of object) :stream stream)))) - -(defmethod display-parse-tree ((parser-symbol lisp-lexeme) stream (view textual-drei-syntax-view) - (syntax lisp-syntax)) - (flet ((cache-test (t1 t2) - (and (eq t1 t2) - (eq (slot-value t1 'ink) - (medium-ink (sheet-medium stream))) - (eq (slot-value t1 'face) - (text-style-face (medium-text-style (sheet-medium stream))))))) - (updating-output - (stream :unique-id (list view parser-symbol) - :id-test #'equal - :cache-value parser-symbol - :cache-test #'cache-test) - (with-slots (ink face) parser-symbol - (setf ink (medium-ink (sheet-medium stream)) - face (text-style-face (medium-text-style (sheet-medium stream)))) - (write-string (form-string syntax parser-symbol) stream))))) - -(define-presentation-type lisp-string () - :description "lisp string") - -(defmethod display-parse-tree ((parse-symbol complete-string-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let ((children (children parse-symbol))) - (if (third children) - (let ((string (buffer-substring (buffer syntax) - (start-offset (second children)) - (end-offset (car (last children 2)))))) - (with-output-as-presentation (stream string 'lisp-string - :single-box :highlighting) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax) - (loop until (null (cdr children)) - do (display-parse-tree (pop children) stream view syntax)) - (display-parse-tree (pop children) stream view syntax)))) - (with-face (:string) - (progn (display-parse-tree (pop children) stream view syntax) - (display-parse-tree (pop children) stream view syntax)))))) - -(defmethod display-parse-tree ((parse-symbol incomplete-string-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let ((children (children parse-symbol))) - (if (second children) - (let ((string (buffer-substring (buffer syntax) - (start-offset (second children)) - (end-offset (car (last children)))))) - (with-output-as-presentation (stream string 'lisp-string - :single-box :highlighting) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax) - (loop until (null children) - do (display-parse-tree (pop children) stream view syntax))))) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax))))) - -(defmethod display-parse-tree ((parse-symbol line-comment-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (with-face (:comment) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol long-comment-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (with-face (:comment) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol reader-conditional-positive-form) - stream (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let ((conditional (second-noncomment (children parse-symbol)))) - (if (eval-feature-conditional conditional syntax) - (call-next-method) - (let ((*current-faces* *reader-conditional-faces*)) - (with-face (:reader-conditional) - (call-next-method)))))) - -(defmethod display-parse-tree ((parse-symbol reader-conditional-negative-form) - stream (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let ((conditional (second-noncomment (children parse-symbol)))) - (if (eval-feature-conditional conditional syntax) - (let ((*current-faces* *reader-conditional-faces*)) - (with-face (:reader-conditional) - (call-next-method))) - (call-next-method)))) - -(defgeneric eval-feature-conditional (conditional-form syntax)) - -(defmethod eval-feature-conditional (conditional-form (syntax lisp-syntax)) - nil) - -;; Adapted from slime.el - -(defconstant +keyword-package+ (find-package :keyword) - "The KEYWORD package.") - -(defmethod eval-feature-conditional ((conditional token-mixin) (syntax lisp-syntax)) - (let* ((string (form-string syntax conditional)) - (symbol (parse-symbol string :package +keyword-package+))) - (member symbol *features*))) - -(defmethod eval-feature-conditional ((conditional list-form) (syntax lisp-syntax)) - (let ((children (children conditional))) - (when (third-noncomment children) - (flet ((eval-fc (conditional) - (funcall #'eval-feature-conditional conditional syntax))) - (let* ((type (second-noncomment children)) - (conditionals (butlast - (nthcdr - 2 - (remove-if - #'comment-p - children)))) - (type-string (form-string syntax type)) - (type-symbol (parse-symbol type-string :package +keyword-package+))) - (case type-symbol - (:and (funcall #'every #'eval-fc conditionals)) - (:or (funcall #'some #'eval-fc conditionals)) - (:not (when conditionals - (funcall #'(lambda (f l) (not (apply f l))) - #'eval-fc conditionals))))))))) +;; Note that we do not colour keyword symbols or special forms yet, +;; that is because the only efficient way to do so is to mark them as +;; interesting in the parser itself, it is too slow to check for it in +;; highlighting rules. +(make-syntax-highlighting-rules emacs-style-highlighting + (error-symbol (:face :ink +red+)) + (string-form (:face :ink +rosy-brown+ + :style (make-text-style nil :italic nil))) + (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large)))) + +(defparameter *syntax-highlighting-rules* 'emacs-style-highlighting + "The syntax highlighting rules used for highlighting Lisp +syntax.") -(defmethod display-parse-tree ((parse-symbol complete-list-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let* ((children (children parse-symbol)) - (point-offset (the fixnum (offset (point view)))) - ;; The following is true if the location if the point - ;; warrants highlighting of a set of matching parentheses. - (should-highlight (and (active view) - (or (= (the fixnum (end-offset parse-symbol)) point-offset) - (= (the fixnum (start-offset parse-symbol)) point-offset))))) - (if should-highlight - (with-text-face (stream :bold) - (display-parse-tree (car children) stream view syntax)) - (display-parse-tree (car children) stream view syntax)) - (loop for child-list on (cdr children) - if (and should-highlight (null (cdr child-list))) do - (with-text-face (stream :bold) - (display-parse-tree (car child-list) stream view syntax)) - else do - (display-parse-tree (car child-list) stream view syntax)))) - -(defmethod display-parse-tree ((parse-symbol incomplete-list-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (update-parse syntax) - (let* ((children (children parse-symbol)) - (point-offset (the fixnum (offset (point view)))) - ;; The following is set to true if the location if the point - ;; warrants highlighting of the beginning parenthesis - (should-highlight (and (active view) - (= (the fixnum (start-offset parse-symbol)) point-offset)))) - (with-face (:error) - (if should-highlight - (with-text-face (stream :bold) - (display-parse-tree (car children) stream view syntax)) - (display-parse-tree (car children) stream view syntax))) - (loop for child in (cdr children) do - (display-parse-tree child stream view syntax)))) +(defmethod syntax-highlighting-rules ((syntax lisp-syntax)) + *syntax-highlighting-rules*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/02 14:43:40 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/03 12:32:08 1.7 @@ -28,7 +28,8 @@ (in-package :drei-lr-syntax) (defclass lr-syntax-mixin () - ((stack-top :initform nil) + ((stack-top :initform nil + :accessor stack-top) (potentially-valid-trees) (lookahead-lexeme :initform nil :accessor lookahead-lexeme) (current-state) @@ -289,6 +290,66 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Utility functions + +(defun invoke-do-parse-symbols-forward (start-offset nearby-symbol fn) + "Loop across the parse symbols of the syntax, calling `fn' on +any parse symbol that starts at or after +`start-offset'. `Nearby-symbol' is the symbol at which the +iteration will start. First, if `nearby-symbol' is at or after +`start-offset', `fn' will be called on +`nearby-symbol'. Afterwards, the children of `nearby-symbol' will +be looped over. Finally, the process will be repeated for each +sibling of `nearby-symbol'. It is guaranteed that `fn' will not +be called twice for the same parser symbol." + (labels ((act (parse-symbol previous) + (when (>= (end-offset parse-symbol) start-offset) + (when (>= (start-offset parse-symbol) start-offset) + (funcall fn parse-symbol)) + (loop for child in (children parse-symbol) + unless (eq child previous) + do (act child parse-symbol))) + (unless (or (null (parent parse-symbol)) + (eq (parent parse-symbol) previous)) + (act (parent parse-symbol) parse-symbol)))) + (act nearby-symbol nearby-symbol))) + +(defmacro do-parse-symbols-forward ((symbol start-offset enclosing-symbol) + &body body) + "Loop across the parse symbols of the syntax, evaluating `body' +with `symbol' bound for each parse symbol that starts at or after +`start-offset'. `enclosing-symbol' is the symbol at which the +iteration will start. First, if `enclosing-symbol' is at or after +`start-offset', `symbol' will be bound to +`enclosing-symbol'. Afterwards, the children of +`enclosing-symbol' will be looped over. Finally, the process will +be repeated for each sibling of `nearby-symbol'. It is guaranteed +that `symbol' will not bound to the same parser symbol twice." + `(invoke-do-parse-symbols-forward ,start-offset ,enclosing-symbol + #'(lambda (,symbol) + ,@body))) + +(defun parser-symbol-containing-offset (syntax offset) + "Find the most specific (leaf) parser symbol in `syntax' that +contains `offset'. If there is no such parser symbol, return the +stack-top of `syntax'." + (labels ((check (parser-symbol) + (cond ((or (and (<= (start-offset parser-symbol) offset) + (< offset (end-offset parser-symbol))) + (= offset (start-offset parser-symbol))) + (return-from parser-symbol-containing-offset + (if (null (children parser-symbol)) + parser-symbol + (or (check-children (children parser-symbol)) + parser-symbol)))) + (t nil))) + (check-children (children) + (find-if #'check children))) + (or (check-children (children (stack-top syntax))) + (stack-top syntax)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; update syntax (defmethod update-syntax ((syntax lr-syntax-mixin) prefix-size suffix-size @@ -317,85 +378,182 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Redisplay. This is just some minor conveniences, not an actual -;;; generic redisplay implementation for LR syntaxes. - -(defvar *current-faces* nil - "The current faces used by the syntax for redisplay. Will be -bound during redisplay.") - -(defstruct (face (:type list) - (:constructor make-face (name colour &optional style))) - name colour (style nil)) - -(defgeneric get-faces (syntax) - (:documentation "Return a list of all the defined standard -faces of `syntax'.") +;;; General redisplay for LR syntaxes, subclasses of `lr-syntax-mixin' +;;; should be able to easily define some syntax rules, and need not +;;; bother with all this complexity. +;;; +;;; _______________ +;;; / \ +;;; / \ +;;; / \ +;;; | XXXX XXXX | +;;; | XXXX XXXX | +;;; | XXX XXX | +;;; | X | +;;; \__ XXX __/ +;;; |\ XXX /| +;;; | | | | +;;; | I I I I I I I | +;;; | I I I I I I | +;;; \_ _/ +;;; \_ _/ +;;; \_______/ +;;; XXX XXX +;;; XXXXX XXXXX +;;; XXXXXXXXX XXXXXXXXXX +;;; XXXXX XXXXX +;;; XXXXXXX +;;; XXXXX XXXXX +;;; XXXXXXXXX XXXXXXXXXX +;;; XXXXX XXXXX +;;; XXX XXX + +(defmacro make-syntax-highlighting-rules (name &body rules) + "Define a set of rules for highlighting a syntax. `Name', which +must be a symbol, is the name of this set of rules, and will be +bound to a function implementing the rules. `Rules' is a list of +rules of the form `(parser-symbol (type args...))', where +`parser-symbol' is a type that might be encountered in a parse +tree for the syntax. The rule specifies how to highlight that +kind of object (and all its children). `Type' can be one of three +symbols. + + `:face', in which case `args' will be used as arguments to a + call to `make-face'. The resulting face will be used to draw + the parsersymbol. + + `:options', in which case `args' will be used as arguments to + `make-drawing-options'. The resulting options will be used to + draw the parser symbol. + + `:function', in which case `args' must be a single element, a + function that takes two arguments. These arguments are the + syntax and the parser symbol, and the return value of this + function is the `drawing-options' object that will be used to + draw the parser-symbol." + (check-type name symbol) + `(progn + (fmakunbound ',name) + (defgeneric ,name (syntax parser-symbol) + (:method (syntax (parser-symbol parser-symbol)) + nil)) + ,@(flet ((make-rule-exp (type args) + (ecase type + (:face `#'(lambda (syntax parser-symbol) + (declare (ignore syntax parser-symbol)) + (make-drawing-options :face (make-face ,@args)))) + (:options `#'(lambda (syntax parser-symbol) + (declare (ignore syntax parser-symbol)) + (make-drawing-options ,@args))) + (:function (first args))))) + (loop for (parser-symbol (type . args)) in rules + collect `(let ((rule ,(make-rule-exp type args))) + (defmethod ,name (syntax (parser-symbol ,parser-symbol)) + (funcall rule syntax parser-symbol))))))) + +(make-syntax-highlighting-rules default-syntax-highlighting) + +(defgeneric syntax-highlighting-rules (syntax) + (:documentation "Return the drawing options that should be used +for displaying `parser-symbol's for `syntax'. A method should be +defined on this function for any syntax that wants syntax +highlighting.") (:method ((syntax lr-syntax-mixin)) - '())) + 'default-syntax-highlighting)) -(defun get-face (name) - "Retrieve face named `name' from `*current-faces*'." - (find name *current-faces* :key #'face-name)) - -(defmacro define-standard-faces (syntax &body faces) - "Define the list of standard faces used by `syntax' to be -`faces', which must be a sequence of forms evaluating to -face-values ((name, colour, style)-triples)." - `(let ((faces-list (list ,@faces))) - (defmethod get-faces ((syntax ,syntax)) - faces-list))) - -(defmacro with-face ((face &optional (stream-symbol 'stream)) &body body) - `(with-drawing-options (,stream-symbol :ink (face-colour (get-face ,face)) - :text-style (face-style (get-face ,face))) - ,@body)) - -(defgeneric display-parse-tree (parse-symbol stream view syntax) - (:documentation "Display the given parse-symbol on `stream', -assuming `view' to be the relevant Drei vire and `syntax' being -the syntax object responsible for the parse symbol.")) - -(defmethod display-parse-tree :before ((parse-symbol lexeme) - stream (view textual-drei-syntax-view) - (syntax lr-syntax-mixin)) - (handle-whitespace stream view (buffer view) - *white-space-start* (start-offset parse-symbol)) - (setf *white-space-start* (end-offset parse-symbol))) - -(defmethod display-parse-tree :around ((parse-symbol parser-symbol) - stream (view textual-drei-syntax-view) - (syntax lr-syntax-mixin)) - (with-accessors ((top top) (bot bot)) view - (when (and (start-offset parse-symbol) - (mark< (start-offset parse-symbol) bot) - (mark> (end-offset parse-symbol) top)) - (call-next-method)))) - -(defmethod display-parse-tree ((parse-symbol parser-symbol) - stream (view textual-drei-syntax-view) - (syntax lr-syntax-mixin)) - (with-accessors ((top top) (bot bot)) view - (loop for child in (children parse-symbol) - when (and (start-offset child) - (mark> (end-offset child) top)) - do (if (mark< (start-offset child) bot) - (display-parse-tree child stream view syntax) - (return))))) - -(defmethod display-syntax-view ((stream clim-stream-pane) (view textual-drei-syntax-view) - (syntax lr-syntax-mixin)) - (update-parse syntax) - (with-accessors ((top top) (bot bot)) view - (with-accessors ((cursor-positions cursor-positions)) view - ;; There must always be room for at least one element of line - ;; information. - (setf cursor-positions (make-array (1+ (number-of-lines-in-region top bot)) - :initial-element nil) - *current-line* 0 - (aref cursor-positions 0) (multiple-value-list - (stream-cursor-position stream)))) - (setf *white-space-start* (offset top))) - (let ((*current-faces* (get-faces syntax))) - (with-slots (stack-top) syntax - (display-parse-tree stack-top stream view syntax)))) +(defun get-drawing-options (highlighting-rules syntax parse-symbol) + "Get the drawing options with which `parse-symbol' should be +drawn. If `parse-symbol' is NIL, return NIL." + (when parse-symbol + (funcall highlighting-rules syntax parse-symbol))) + +(defstruct (pump-state + (:constructor make-pump-state + (parser-symbol offset drawing-options + highlighting-rules))) + "A pump state object used in the LR syntax +module. `parser-symbol' is the a parse symbol object `offset' is +in. `Drawing-options' is a stack with elements `(end-offset +drawing-options)', where `end-offset' specifies there the drawing +options specified by `drawing-options' stop. `Highlighting-rules' +is the rules that are used for syntax highlighting." + parser-symbol offset + drawing-options highlighting-rules) + +(defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view) + (syntax lr-syntax-mixin) (offset integer)) + (update-parse syntax 0 offset) + (let ((parser-symbol (parser-symbol-containing-offset syntax offset)) + (highlighting-rules (syntax-highlighting-rules syntax))) + (labels ((initial-drawing-options (parser-symbol) + (if (null parser-symbol) + (cons (size (buffer view)) +default-drawing-options+) + (let ((drawing-options + (get-drawing-options highlighting-rules syntax parser-symbol))) + (if (null drawing-options) + (initial-drawing-options (parent parser-symbol)) + (cons (end-offset parser-symbol) drawing-options)))))) + (make-pump-state parser-symbol offset + (list (initial-drawing-options parser-symbol) + (cons (1+ (size (buffer view))) +default-drawing-options+)) + highlighting-rules)))) + +(defun find-next-stroke-end (syntax pump-state) + "Assuming that `pump-state' contains the previous pump state, +find out where the next stroke should end, and possibly push some +drawing options onto `pump-state'." + (with-accessors ((start-symbol pump-state-parser-symbol) + (offset pump-state-offset) + (drawing-options pump-state-drawing-options) + (highlighting-rules pump-state-highlighting-rules)) + pump-state + (let ((line (line-containing-offset syntax offset))) + (flet ((finish (offset symbol &optional stroke-drawing-options) + (setf start-symbol symbol) + (loop until (> (car (first drawing-options)) offset) + do (pop drawing-options)) + (unless (null stroke-drawing-options) + (push (cons (end-offset symbol) stroke-drawing-options) + drawing-options)) + (return-from find-next-stroke-end + offset))) + (if (null start-symbol) + ;; This means that all remaining lines are blank. + (finish (line-end-offset line) nil) + (or (do-parse-symbols-forward (symbol offset start-symbol) + (let ((symbol-drawing-options + (get-drawing-options highlighting-rules syntax symbol))) + (cond ((> (start-offset symbol) (line-end-offset line)) + (finish (line-end-offset line) start-symbol)) + ((and (> (start-offset symbol) offset) + (not (drawing-options-equal (or symbol-drawing-options + +default-drawing-options+) + (cdr (first drawing-options))))) + (finish (start-offset symbol) symbol symbol-drawing-options)) + ((and (= (start-offset symbol) offset) + (offset-beginning-of-line-p (buffer syntax) offset) + (and symbol-drawing-options + (not (drawing-options-equal symbol-drawing-options + (cdr (first drawing-options)))))) + (finish (start-offset symbol) symbol symbol-drawing-options))))) + ;; If there are no more parse symbols, we just go + ;; line-by-line from here. This should mean that all + ;; remaining lines are blank. + (finish (line-end-offset line) nil))))))) + +(defmethod stroke-pump-with-syntax ((view textual-drei-syntax-view) + (syntax lr-syntax-mixin) stroke + (pump-state pump-state)) + ;; `Pump-state' will be destructively modified. + (prog1 pump-state + (with-accessors ((offset pump-state-offset) + (current-drawing-options pump-state-drawing-options)) + pump-state + (let ((old-drawing-options (cdr (first current-drawing-options))) + (end-offset (find-next-stroke-end syntax pump-state))) + (setf (stroke-start-offset stroke) offset + (stroke-end-offset stroke) end-offset + (stroke-drawing-options stroke) old-drawing-options + offset (if (offset-end-of-line-p (buffer view) end-offset) + (1+ end-offset) + end-offset)))))) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/02 14:43:40 1.29 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/03 12:32:08 1.30 @@ -169,8 +169,6 @@ #:display-syntax-name #:syntax-line-indentation #:eval-defun - #:record-line-vertical-offset - #:line-vertical-offset #:syntax-line-comment-string #:line-comment-region #:comment-region #:line-uncomment-region #:uncomment-region @@ -487,13 +485,15 @@ (:use :clim-lisp :clim :drei-buffer :drei-base :drei-syntax :flexichain :drei :drei-core) (:export #:fundamental-syntax #:scan - #:*current-line* #:*white-space-start* #:handle-whitespace) + #:start-mark #:line-length #:line-end-offset + #:line-containing-offset #:offset-in-line-p) (:documentation "Implementation of the basic syntax module for editing plain text.")) (defpackage :drei-lr-syntax (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base - :drei-syntax :drei :drei-core :drei-fundamental-syntax) + :drei-syntax :drei :drei-core :drei-fundamental-syntax + :esa-utils) (:export #:lr-syntax-mixin #:stack-top #:initial-state #:skip-inter #:lex #:define-lexer-state #:lexer-toplevel-state #:lexer-error-state @@ -505,10 +505,8 @@ #:action #:new-state #:done #:reduce-fixed-number #:reduce-until-type #:reduce-all #:error-state #:error-reduce-state - #:*current-faces* - #:make-face #:face-name #:face-colour #:face-style - #:get-faces #:define-standard-faces #:with-face - #:display-parse-tree) + #:make-syntax-highlighting-rules + #:syntax-highlighting-rules) (:documentation "Underlying LR parsing functionality.")) (defpackage :drei-lisp-syntax @@ -564,8 +562,6 @@ #:at-end-of-string-p #:at-beginning-of-children-p #:at-end-of-children-p - #:structurally-at-beginning-of-children-p - #:structurally-at-end-of-children-p #:comment-at-mark ;; Lambda list classes.

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 02 Jan '08

02 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv22872/Drei Modified Files: base.lisp drei-redisplay.lisp fundamental-syntax.lisp lr-syntax.lisp packages.lisp views.lisp Log Message: Connect redisplay to syntax information. Currently, the necessary methods are only implemented for Fundamental syntax, so there is still no syntax highlighting. There is, however, a 30-40% performance increase in redisplay, as Fundamental syntax is much better at keeping track of buffer contents than the hack I wrote for drei-buffer-view. --- /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2007/12/27 13:39:25 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2008/01/02 14:43:40 1.9 @@ -381,6 +381,56 @@ *kill-ring* (region-to-sequence mark1 mark2)) (delete-region mark1 mark2)) +(defun in-place-buffer-substring (buffer string offset1 offset2) + "Copy from `offset1' to `offset2' in `buffer' to `string', +which must be an adjustable vector of characters with a fill +pointer. All objects in the buffer range must be +characters. Returns `string'." + (loop for offset from offset1 below offset2 + for i upfrom 0 + do (vector-push-extend (buffer-object buffer offset) string) + finally (return string))) + +(defun fill-string-from-buffer (buffer string offset1 offset2) + "Copy from `offset1' to `offset2' in `buffer' to `string', +which must be an adjustable vector of characters with a fill +pointer. Once the buffer region has been copied to `string', or a +non-character object has been encountered in the buffer, the +number of characters copied to `string' will be returned." + (loop for offset from offset1 below offset2 + for i upfrom 0 + if (characterp (buffer-object buffer offset)) + do (vector-push-extend (buffer-object buffer offset) string) + else do (loop-finish) + finally (return i))) + +(defun buffer-find-nonchar (buffer start-offset max-offset) + "Search through `buffer' from `start-offset', returning the +first offset at which a non-character object is found, or +`max-offset', whichever comes first." + (loop for offset from start-offset below max-offset + unless (characterp (buffer-object buffer offset)) + do (loop-finish) + finally (return offset))) + +(defun offset-beginning-of-line-p (buffer offset) + "Return true if `offset' is at the beginning of a line in +`buffer' or at the beginning of `buffer'." + (or (zerop offset) (eql (buffer-object buffer (1- offset)) #\Newline))) + +(defun offset-end-of-line-p (buffer offset) + "Return true if `offset' is at the end of a line in +`buffer' or at the end of `buffer'." + (or (= (size buffer) offset) + (eql (buffer-object buffer offset) #\Newline))) + +(defun end-of-line-offset (buffer start-offset) + "Return the offset of the end of the line of `buffer' +containing `start-offset'." + (loop for offset from start-offset + until (offset-end-of-line-p buffer offset) + finally (return offset))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Character case --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/02 10:03:02 1.16 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/02 14:43:40 1.17 @@ -80,8 +80,7 @@ applicable. This method will only be called by the Drei redisplay engine when the cursor is active and the buffer position it refers to is on display - therefore, `offset-to-screen-position' -is *guaranteed* to not return NIL or T. This function will return -either the output record of the cursor, or NIL.") +is *guaranteed* to not return NIL or T.") (:method :around ((stream extended-output-stream) (view drei-view) (cursor drei-cursor)) (when (visible cursor view) @@ -198,40 +197,59 @@ (:documentation "Return a pump state that will enable pumping strokes from `offset' in the buffer of `view' (via `stroke-pump'). The pump state is not guaranteed to be valid past -the next call to `stroke-pump' or `synchronize-view'.")) +the next call to `stroke-pump' or `synchronize-view'. The results +are undefined if `offset' is not at the beginning of a line.") + (:method ((view drei-syntax-view) (offset integer)) + (pump-state-for-offset-with-syntax view (syntax view) offset))) (defgeneric stroke-pump (view stroke pump-state) - (:documentation "Put stroke information in `stroke'. Returns -new pump-state.")) - -(defun in-place-buffer-substring (buffer string offset1 offset2) - "Copy from `offset1' to `offset2' in `buffer' to `string', -which must be an adjustable vector of characters with a fill -pointer. All objects in the buffer range must be -characters. Returns `string'." - (loop for offset from offset1 below offset2 - for i upfrom 0 - do (vector-push-extend (buffer-object buffer offset) string) - finally (return string))) - -(defun fill-string-from-buffer (buffer string offset1 offset2) - "Copy from `offset1' to `offset2' in `buffer' to `string', -which must be an adjustable vector of characters with a fill -pointer. Once the buffer region has been copied to `string', or a -non-character object has been encountered in the buffer, the -number of characters copied to `string' will be returned." - (loop for offset from offset1 below offset2 - for i upfrom 0 - if (characterp (buffer-object buffer offset)) - do (vector-push-extend (buffer-object buffer offset) string) - else do (loop-finish) - finally (return i))) + (:documentation "Put stroke information in `stroke', returns +new pump-state. `Pump-state' must either be the result of a call +to `pump-state-for-offset' or be the return value of an earlier +call to `stroke-pump'. A pump state is not guaranteed to be +valid past the next call to `stroke-pump' or +`synchronize-view'. It is permissible for `pump-state' to be +destructively modified by this function.") + (:method :around ((view drei-buffer-view) stroke pump-state) + ;; `call-next-method' for the next pump state, and compare + ;; the new stroke data with the old one. If it has changed, + ;; mark the stroke as dirty and modified. + (let ((old-start-offset (stroke-start-offset stroke)) + (old-end-offset (stroke-end-offset stroke)) + (old-drawing-options (stroke-drawing-options stroke)) + (new-pump-state (call-next-method))) + (unless (and old-start-offset + (= old-start-offset (stroke-start-offset stroke)) + (= old-end-offset (stroke-end-offset stroke)) + (drawing-options-equal old-drawing-options + (stroke-drawing-options stroke))) + (invalidate-stroke stroke :modified t)) + new-pump-state)) + (:method ((view drei-syntax-view) stroke pump-state) + (stroke-pump-with-syntax view (syntax view) stroke pump-state))) (defun clear-rectangle* (stream x1 y1 x2 y2) "Draw on `stream' from (x1,y1) to (x2,y2) with the background ink for the stream." (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+)) +(defun invalidate-stroke (stroke &key modified cleared) + "Invalidate `stroke' by setting its dirty-bit to true. If +`modified' or `cleared' is true, also set the modified-bit to +true. If `cleared' is true, inform the stroke that its previous +output has been cleared by someone, and that it does not need to +clear it itself during its next redisplay." + (setf (stroke-dirty stroke) t + (stroke-modified stroke) + (or (stroke-modified stroke) + modified + cleared)) + (when cleared + (setf (x1 (stroke-dimensions stroke)) 0 + (y1 (stroke-dimensions stroke)) 0 + (x2 (stroke-dimensions stroke)) 0 + (y2 (stroke-dimensions stroke)) 0))) + (defun invalidate-line-strokes (line &key modified cleared) "Invalidate all the strokes of `line' by setting their dirty-bit to true. If `modified' or `cleared' is true, also set @@ -240,17 +258,8 @@ and that they do not need to clear it themselves during their next redisplay." (loop for stroke across (line-strokes line) - do (setf (stroke-dirty stroke) t - (stroke-modified stroke) - (or (stroke-modified stroke) - modified - cleared)) - when cleared - do (let ((dimensions (stroke-dimensions stroke))) - (setf (x1 dimensions) 0 - (y1 dimensions) 0 - (x2 dimensions) 0 - (y2 dimensions) 0)))) + do (invalidate-stroke stroke :modified modified + :cleared cleared))) (defun invalidate-all-strokes (view &key modified cleared) "Invalidate all the strokes of `view' by setting their @@ -560,33 +569,6 @@ the buffer determining where the next stroke should start." offset) -(defun buffer-find-nonchar (buffer start-offset max-offset) - "Search through `buffer' from `start-offset', returning the -first offset at which a non-character object is found, or -`max-offset', whichever comes first." - (loop for offset from start-offset below max-offset - unless (characterp (buffer-object buffer offset)) - do (loop-finish) - finally (return offset))) - -(defun offset-beginning-of-line-p (buffer offset) - "Return true if `offset' is at the beginning of a line in -`buffer' or at the beginning of `buffer'." - (or (zerop offset) (eql (buffer-object buffer (1- offset)) #\Newline))) - -(defun offset-end-of-line-p (buffer offset) - "Return true if `offset' is at the end of a line in -`buffer' or at the end of `buffer'." - (or (= (size buffer) offset) - (eql (buffer-object buffer offset) #\Newline))) - -(defun end-of-line-offset (buffer start-offset) - "Return the offset of the end of the line of `buffer' -containing `start-offset'." - (loop for offset from start-offset - until (offset-end-of-line-p buffer offset) - finally (return offset))) - (defun fetch-chunk (buffer chunk-start-offset) "Retrieve a chunk from `buffer', with the chunk starting at `chunk-start-offset'. The chunk is a cons, with the car being the @@ -617,16 +599,9 @@ (actual-end-offset (if (functionp (cdr chunk)) (1+ (car chunk)) (cdr chunk)))) - (unless (and (stroke-start-offset stroke) - (= (stroke-start-offset stroke) (car chunk)) - (= (stroke-end-offset stroke) actual-end-offset) - (drawing-options-equal (stroke-drawing-options stroke) - drawing-options)) - (setf (stroke-start-offset stroke) (car chunk) - (stroke-end-offset stroke) actual-end-offset - (stroke-modified stroke) t - (stroke-dirty stroke) t - (stroke-drawing-options stroke) drawing-options)) + (setf (stroke-start-offset stroke) (car chunk) + (stroke-end-offset stroke) actual-end-offset + (stroke-drawing-options stroke) drawing-options) (if (offset-end-of-line-p (buffer view) actual-end-offset) (1+ actual-end-offset) actual-end-offset))) @@ -673,7 +648,6 @@ the end of the buffer.")) (defmethod offset-to-screen-position ((pane clim-stream-pane) (view drei-view) (offset number)) - (declare (optimize (debug 3))) (flet ((worker () (do-displayed-lines (line view) (when (<= (line-start-offset line) offset (line-end-offset line)) @@ -728,33 +702,29 @@ (view drei-buffer-view) (cursor drei-cursor)) (when (<= (offset (top view)) (offset (mark cursor)) (offset (bot view))) - (let ((cursor-output-record (call-next-method))) - (when cursor-output-record - (with-bounding-rectangle* (x1 y1 x2 y2) cursor-output-record - (do-displayed-lines (line view) - (cond ((> (y1 (line-dimensions line)) y2) - (return)) - ((coordinates-intersects-dimensions - (line-dimensions line) x1 y1 x2 y2) - (block stroke-loop - (do-displayed-line-strokes (stroke line) - (cond ((> (x1 (stroke-dimensions stroke)) x2) - (return-from stroke-loop)) - ((coordinates-intersects-dimensions - (stroke-dimensions stroke) x1 y1 x2 y2) - (setf (stroke-dirty stroke) t) - (setf (stroke-modified stroke) t))))))))))))) + (clear-output-record cursor) + (prog1 (call-next-method) + (with-bounding-rectangle* (x1 y1 x2 y2) cursor + (do-displayed-lines (line view) + (cond ((> (y1 (line-dimensions line)) y2) + (return)) + ((coordinates-intersects-dimensions + (line-dimensions line) x1 y1 x2 y2) + (block stroke-loop + (do-displayed-line-strokes (stroke line) + (cond ((> (x1 (stroke-dimensions stroke)) x2) + (return-from stroke-loop)) + ((coordinates-intersects-dimensions + (stroke-dimensions stroke) x1 y1 x2 y2) + (setf (stroke-dirty stroke) t) + (setf (stroke-modified stroke) t)))))))))))) (defmethod display-drei-view-cursor ((stream extended-output-stream) (view drei-buffer-view) (cursor drei-cursor)) (multiple-value-bind (cursor-x cursor-y line-height object-width) (offset-to-screen-position stream view (offset (mark cursor))) - (updating-output (stream :unique-id (list* stream view cursor) - :id-test #'equal - :cache-value (list* cursor-x cursor-y line-height object-width) - :cache-test #'equal - :all-new t) + (letf (((stream-current-output-record stream) cursor)) (draw-rectangle* stream cursor-x cursor-y (+ cursor-x object-width) (+ cursor-y line-height) @@ -917,7 +887,6 @@ (change-space-requirements pane :width output-width)))) (defmethod fix-pane-viewport :after ((pane drei-pane) (view point-mark-view)) - (declare (optimize (debug 3))) (when (and (pane-viewport pane) (active pane)) (multiple-value-bind (cursor-x cursor-y line-height object-width) (offset-to-screen-position pane view (offset (point view))) --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2007/12/08 08:53:50 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/02 14:43:40 1.8 @@ -34,7 +34,8 @@ ;;; The syntax object and misc stuff. (define-syntax fundamental-syntax (syntax) - ((lines :initform (make-instance 'standard-flexichain)) + ((lines :initform (make-instance 'standard-flexichain) + :reader lines) (scan :accessor scan)) (:command-table fundamental-table) (:name "Fundamental")) @@ -51,24 +52,54 @@ ;;; update syntax (defclass line-object () - ((start-mark :initarg :start-mark :reader start-mark))) - -(defmethod update-syntax-for-display (buffer (syntax fundamental-syntax) top bot) - nil) + ((%start-mark :reader start-mark + :initarg :start-mark) + (%chunks :accessor chunks + :initform (make-array 5 + :adjustable t + :fill-pointer 0)))) + +(defun get-chunk (buffer chunk-start-offset line-end-offset) + (let* ((chunk-end-offset (buffer-find-nonchar + buffer chunk-start-offset + (min (+ *maximum-chunk-size* + chunk-start-offset) + line-end-offset)))) + (cond ((= chunk-start-offset line-end-offset) + (cons chunk-end-offset nil)) + ((or (not (= chunk-end-offset chunk-start-offset)) + (and (offset-beginning-of-line-p buffer chunk-start-offset) + (offset-end-of-line-p buffer chunk-end-offset))) + (cons chunk-end-offset nil)) + ((not (characterp (buffer-object buffer chunk-end-offset))) + (cons (1+ chunk-end-offset) t))))) + +(defmethod initialize-instance :after ((line line-object) + &rest initargs) + (declare (ignore initargs)) + (loop with buffer = (buffer (start-mark line)) + with chunk-start-offset = (offset (start-mark line)) + with line-end-offset = (end-of-line-offset buffer (offset (start-mark line))) + for chunk-info = (get-chunk (buffer (start-mark line)) + chunk-start-offset line-end-offset) + do (vector-push-extend chunk-info (chunks line)) + (setf chunk-start-offset (car chunk-info)) + when (= chunk-start-offset line-end-offset) + do (loop-finish))) (defmethod update-syntax ((syntax fundamental-syntax) prefix-size suffix-size &optional begin end) (declare (ignore begin end)) - (let ((low-mark (clone-mark (scan syntax) :left)) - (high-mark (clone-mark (scan syntax) :left))) - (setf (offset low-mark) prefix-size - (offset high-mark) (- (size (buffer syntax)) suffix-size)) + (let ((low-mark (make-buffer-mark (buffer syntax) prefix-size :left)) + (high-mark (make-buffer-mark + (buffer syntax) (- (size (buffer syntax)) suffix-size) :left))) (when (mark<= low-mark high-mark) (beginning-of-line low-mark) (end-of-line high-mark) (with-slots (lines scan) syntax (let ((low-index 0) (high-index (nb-elements lines))) + ;; Binary search for the start of changed lines. (loop while (< low-index high-index) do (let* ((middle (floor (+ low-index high-index) 2)) (line-start (start-mark (element* lines middle)))) @@ -76,139 +107,91 @@ (setf low-index (1+ middle))) (t (setf high-index middle))))) - ;; discard lines that have to be re-analyzed + ;; Discard lines that have to be re-analyzed. (loop while (and (< low-index (nb-elements lines)) (mark<= (start-mark (element* lines low-index)) high-mark)) do (delete* lines low-index)) - ;; analyze new lines + ;; Analyze new lines. (setf (offset scan) (offset low-mark)) - (loop while (and (mark<= scan high-mark) - (not (end-of-buffer-p scan))) + (loop while (mark<= scan high-mark) for i from low-index do (progn (insert* lines i (make-instance 'line-object :start-mark (clone-mark scan))) (end-of-line scan) - (unless (end-of-buffer-p scan) - ;; skip newline - (forward-object scan))))))))) + (if (end-of-buffer-p scan) + (loop-finish) + ;; skip newline + (forward-object scan))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; display -(defvar *white-space-start* nil) - -(defvar *current-line* 0) - -(defun handle-whitespace (pane view buffer start end) - (let ((space-width (space-width pane view)) - (tab-width (tab-width pane view))) - (with-sheet-medium (medium pane) - (with-accessors ((cursor-positions cursor-positions)) view - (loop while (< start end) - do (case (buffer-object buffer start) - (#\Newline (record-line-vertical-offset pane view (incf *current-line*)) - (terpri pane) - (stream-increment-cursor-position - pane (first (aref cursor-positions 0)) 0)) - ((#\Page #\Return #\Space) (stream-increment-cursor-position - pane space-width 0)) - (#\Tab (when (plusp tab-width) - (let ((x (stream-cursor-position pane))) - (stream-increment-cursor-position - pane (- tab-width (mod x tab-width)) 0))))) - (incf start)))))) - -(defmethod display-line ((stream clim-stream-pane) (view textual-drei-syntax-view) mark) - (let ((mark (clone-mark mark))) - (let ((saved-offset nil) - (id 0) - (space-width (space-width stream view)) - (tab-width (tab-width stream view))) - (flet ((output-word () - (unless (null saved-offset) - (let ((contents (coerce (region-to-sequence - saved-offset - mark) - 'string))) - (updating-output (stream :unique-id (cons view (incf id)) - :id-test #'equal - :cache-value contents - :cache-test #'equal) - (unless (null contents) - (present contents 'string :stream stream)))) - (setf saved-offset nil)))) - (loop - until (end-of-line-p mark) - do (let ((obj (object-after mark))) - (cond ((eql obj #\Space) - (output-word) - (stream-increment-cursor-position stream space-width 0)) - ((eql obj #\Tab) - (output-word) - (let ((x (stream-cursor-position stream))) - (stream-increment-cursor-position - stream (- tab-width (mod x tab-width)) 0))) - ((constituentp obj) - (when (null saved-offset) - (setf saved-offset (offset mark)))) - ((characterp obj) - (output-word) - (updating-output (stream :unique-id (cons stream (incf id)) - :id-test #'equal - :cache-value obj) - (present obj 'character :stream stream))) - (t - (output-word) - (updating-output (stream :unique-id (cons stream (incf id)) - :id-test #'equal - :cache-value obj - :cache-test #'eq) - (present obj (presentation-type-of obj) - :stream stream))))) - do (forward-object mark) - finally - (output-word) - (unless (end-of-buffer-p mark) - (terpri stream))))))) - -(defmethod display-syntax-view ((stream clim-stream-pane) (view textual-drei-syntax-view) - (syntax fundamental-syntax)) - (update-parse syntax) - (with-accessors ((top top) (bot bot)) view - (with-accessors ((cursor-positions cursor-positions)) view - (setf cursor-positions (make-array (1+ (number-of-lines-in-region top bot)) - :initial-element nil - :fill-pointer 1 - :adjustable t) - *current-line* 0 - (aref cursor-positions 0) (multiple-value-list (stream-cursor-position stream)))) - (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 (stream :unique-id (cons view i) - :id-test #'equal - :cache-value line - :cache-test #'equal) - (display-line stream view (start-mark (element* lines i)))))))))) +(defstruct (pump-state + (:constructor make-pump-state + (line-index offset chunk-index))) + "A pump state object used in the fundamental syntax. `Line' is +the line object `offset' is in, and `line-index' is the index of +`line' in the list of lines maintained by the syntax that created +this pump state." + line-index + offset + chunk-index) + +(defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view) + (syntax fundamental-syntax) (offset integer)) + (update-parse syntax 0 offset) + ;; Perform binary search looking for line starting with `offset'. + (with-accessors ((lines lines)) syntax + (loop with low-index = 0 + with high-index = (nb-elements lines) + for middle = (floor (+ low-index high-index) 2) + for line-start = (start-mark (element* lines middle)) + do (cond ((mark> offset line-start) + (setf low-index (1+ middle))) + ((mark< offset line-start) + (setf high-index middle)) + ((mark= offset line-start) + (loop-finish))) + finally (return (make-pump-state middle offset 0))))) + +(defun fetch-chunk (line chunk-index) + "Retrieve the `chunk-index'th chunk from `line'. The return +value is either an integer, in which case it specifies the +end-offset of a string chunk, or a function, in which case it is +the drawing function for a single-object non-character chunk." + (destructuring-bind (chunk-end-offset . objectp) + (aref (chunks line) chunk-index) + (if objectp (object-drawer) chunk-end-offset))) + +(defmethod stroke-pump-with-syntax ((view textual-drei-syntax-view) + (syntax fundamental-syntax) stroke + (pump-state pump-state)) + ;; `Pump-state' will be destructively modified. + (prog1 pump-state + (with-accessors ((line-index pump-state-line-index) + (offset pump-state-offset) + (chunk-index pump-state-chunk-index)) pump-state + (update-parse syntax 0 offset) + (let* ((chunk (fetch-chunk + (element* (lines syntax) line-index) chunk-index)) + (drawing-options (if (functionp chunk) + (make-drawing-options :function chunk) + +default-drawing-options+)) + (end-offset (if (functionp chunk) + (1+ offset) + chunk))) + (setf (stroke-start-offset stroke) offset + (stroke-end-offset stroke) end-offset + (stroke-drawing-options stroke) drawing-options) + (if (offset-end-of-line-p (buffer view) end-offset) + (setf line-index (1+ line-index) + chunk-index 0 + offset (1+ end-offset)) + (setf chunk-index (1+ chunk-index) + offset end-offset)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2007/12/19 17:17:37 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/02 14:43:40 1.6 @@ -294,6 +294,7 @@ (defmethod update-syntax ((syntax lr-syntax-mixin) prefix-size suffix-size &optional begin end) (declare (ignore begin end)) + (call-next-method) (let* ((low-mark-offset prefix-size) (high-mark-offset (- (size (buffer syntax)) suffix-size))) (when (<= low-mark-offset high-mark-offset) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/01 18:43:36 1.28 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/02 14:43:40 1.29 @@ -105,6 +105,12 @@ #:just-n-spaces #:move-to-column #:kill-region + #:in-place-buffer-substring + #:fill-string-from-buffer + #:buffer-find-nonchar + #:offset-beginning-of-line-p + #:offset-end-of-line-p + #:end-of-line-offset #:buffer-whitespacep #:buffer-region-case #:buffer-looking-at #:looking-at @@ -211,6 +217,8 @@ #:drei-view #:modified-p #:no-cursors #:drei-buffer-view #:buffer #:top #:bot #:drei-syntax-view #:syntax + #:pump-state-for-offset-with-syntax + #:stroke-pump-with-syntax #:point-mark-view #:textual-drei-syntax-view #:tab-space-count #:space-width #:tab-width #:use-tabs @@ -243,8 +251,17 @@ #:drei #:drei-pane #:drei-gadget-pane #:drei-area #:handling-drei-conditions #:handle-drei-condition #:execute-drei-command - #:display-drei-view-contents #:display-syntax-view - #:display-drei-view-cursor + #:display-drei-view-contents #:display-drei-view-cursor + + #:face #:make-face #:face-ink #:face-style + #:drawing-options #:make-drawing-options + #:drawing-options-face #:drawing-options-function + #:drawing-options-equal #:+default-drawing-options+ + #:stroke-start-offset #:stroke-end-offset + #:stroke-drawing-options + + #:pump-state-for-offset #:stroke-pump + #:object-drawer #:*maximum-chunk-size* #:with-drei-options #:performing-drei-operations #:invoke-performing-drei-operations #:with-bound-drei-special-variables --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/01 18:43:36 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/02 14:43:40 1.10 @@ -683,6 +683,25 @@ (synchronize-view view :begin begin :end end))) args)) +(defgeneric pump-state-for-offset-with-syntax (view syntax offset) + (:documentation "Return a pump state that will enable pumping +strokes from `offset' in the buffer of `view' as specified by +`syntax' (via `stroke-pump-for-syntax'). The pump state is not +guaranteed to be valid past the next call to +`stroke-pump-for-syntax' or `synchronize-view'. The results are +undefined if `offset' is not at the beginning of a line.")) + +(defgeneric stroke-pump-with-syntax (view syntax stroke pump-state) + (:documentation "Put stroke information in `stroke' as +specified by `syntax', returns new pump-state. `Pump-state' must +either be the result of a call to +`pump-state-for-offset-with-syntax' or be the return value of an +earlier call to `stroke-pump-with-syntax'. A pump state is not +guaranteed to be valid past the next call to +`stroke-pump-with-syntax' or `synchronize-view'. It is +permissible for `pump-state' to be destructively modified by this +function.")) + (defclass point-mark-view (drei-buffer-view) ((%point :initform nil :initarg :point :accessor point-of) (%mark :initform nil :initarg :mark :accessor mark-of))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 02 Jan '08

02 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv17882/Drei Modified Files: lisp-syntax.lisp Log Message: Apparently, git is really stupid about files that change while you're writing the commit message. CVS is much better! Fixed last commit. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/02 14:19:36 1.43 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/02 14:21:06 1.44 @@ -2110,7 +2110,7 @@ (funcall fn list-child))))) (defmethod backward-one-expression (mark (syntax lisp-syntax)) - (update-parse syntax 0 0) + (update-parse syntax 0 (offset mark)) (let ((potential-form (or (form-before syntax (offset mark)) (form-around syntax (offset mark))))) (when (and (not (null potential-form))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 02 Jan '08

02 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15790/Drei Modified Files: lisp-syntax.lisp Log Message: Changed erroneous and performance-killing call to update-syntax to a call to update-parse. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/27 15:22:54 1.42 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/02 14:19:36 1.43 @@ -2110,7 +2110,7 @@ (funcall fn list-child))))) (defmethod backward-one-expression (mark (syntax lisp-syntax)) - (update-syntax syntax 0 0) + (update-parse syntax 0 0) (let ((potential-form (or (form-before syntax (offset mark)) (form-around syntax (offset mark))))) (when (and (not (null potential-form))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 02 Jan '08

02 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv20240/Drei Modified Files: drei-redisplay.lisp Log Message: Fixed some bugs in Drei's cursor-positioning and stroke-size-calculation code. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/01 21:17:56 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/02 10:03:02 1.16 @@ -400,7 +400,7 @@ (text-size stream stroke-string :text-style (merge-text-styles (face-style (drawing-options-face drawing-options)) - (medium-default-text-style stream))) + (medium-merged-text-style (sheet-medium stream)))) (values (- x2 x1) (- y2 y1))) (clear-rectangle* stream cursor-x cursor-y (+ cursor-x width) (+ cursor-y height @@ -488,9 +488,9 @@ buffer offset `start-offset', and will be drawn starting at (`cursor-x', `cursor-y')" (let* ((line (line-information view (displayed-lines-count view))) - (orig-x-offset cursor-x) (old-line-height (dimensions-height (line-dimensions line))) - (old-line-width (dimensions-width (line-dimensions line)))) + (old-line-width (dimensions-width (line-dimensions line))) + (orig-x-offset cursor-x)) (setf (line-start-offset line) start-offset (line-stroke-count line) 0) (loop for index from 0 @@ -662,7 +662,7 @@ (face-style (drawing-options-face (stroke-drawing-options stroke))) - (medium-default-text-style stream)))) + (medium-merged-text-style (sheet-medium stream))))) (defgeneric offset-to-screen-position (pane view offset) (:documentation "Returns the position of offset as a screen @@ -687,10 +687,9 @@ (return-from worker (values (x1 stroke-dimensions) (y1 stroke-dimensions) (dimensions-height line-dimensions) - (- (if (= end-offset (1+ start-offset)) - (x2 stroke-dimensions) - (offset-in-stroke-position pane view stroke (1+ offset))) - (x1 stroke-dimensions))))) + (if (= end-offset (1+ start-offset)) + (dimensions-width stroke-dimensions) + (offset-in-stroke-position pane view stroke (1+ offset)))))) ((and (<= start-offset offset) (< offset end-offset)) (return-from worker @@ -706,7 +705,9 @@ worker (values (x2 line-dimensions) (y1 line-dimensions) (dimensions-height line-dimensions)))))))) (with-accessors ((buffer buffer) (top top) (bot bot)) view - (let ((default-object-width (text-style-width (medium-default-text-style pane) pane))) + (let ((default-object-width + (text-style-width + (medium-merged-text-style (sheet-medium pane)) pane))) (cond ((< offset (offset top)) nil) ((< (offset bot) offset) t)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 02 Jan '08

02 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11012/Drei Modified Files: drei-clim.lisp Log Message: Oops, Drei panes should not use incremental redisplay for now. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/01 18:43:36 1.26 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/02 09:20:26 1.27 @@ -151,13 +151,13 @@ (defclass drei-pane (drei application-pane) () (:default-initargs - :incremental-redisplay t - :end-of-line-action :scroll - :background *background-color* - :foreground *foreground-color* - :display-function 'display-drei-pane - :width 900 - :active nil) + :incremental-redisplay nil + :end-of-line-action :scroll + :background *background-color* + :foreground *foreground-color* + :display-function 'display-drei-pane + :width 900 + :active nil) (:documentation "An actual, instantiable Drei pane that permits (and requires) the host application to control the command loop completely."))

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 01 Jan '08

01 Jan '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19441 Modified Files: panes.lisp Log Message: Removed ancient and seemingly now-unnecessary gilberthack. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2007/12/16 14:27:22 1.185 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2008/01/01 23:23:07 1.186 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.185 2007/12/16 14:27:22 thenriksen Exp $ +;;; $Id: panes.lisp,v 1.186 2008/01/01 23:23:07 thenriksen Exp $ (in-package :clim-internals) @@ -2784,13 +2784,10 @@ (unless borderp user-sr)))) (when borderp - (setq pane (make-pane 'border-pane - :border-width border-width - :contents (list pane))) - ;; bright, I begin to hate the border-pane - (setf pane (apply #'make-pane 'vrack-pane - :contents (list pane) - user-sr))) + (setq pane (apply #'make-pane 'border-pane + :border-width border-width + :contents (list pane) + user-sr))) pane)))) (defun make-clim-interactor-pane (&rest options)

1 0