Changeset 6582 for branches

Timestamp:

May 20, 2007, 9:06:35 AM (18 years ago)

Author:

Gary Byers

Message:

Back out of gap-context change, for now.

Location:

branches/ide-1.0/ccl/hemlock/src

Files:

• line.lisp (modified) (1 diff)
• linimage.lisp (modified) (5 diffs)
• macros.lisp (modified) (2 diffs)
• search1.lisp (modified) (2 diffs)
• struct.lisp (modified) (2 diffs)

branches/ide-1.0/ccl/hemlock/src/line.lisp

@@ -140 +140 @@
 (defmacro line-length* (line)
   "Returns the number of characters on the line, but it's a macro!"
-  (let* ((buffer (gensym)))
-    `(let* ((,buffer (line-%buffer ,line)))
-      (cond ((eq ,line (buffer-open-line ,buffer))
-             (+ (buffer-left-open-pos ,buffer) (- (buffer-line-cache-length ,buffer) (buffer-right-open-pos ,buffer))))
-            ((line-buffered-p ,line))
-            (t
-             (length (the simple-string (line-%chars ,line))))))))
+  `(cond ((eq ,line *open-line*)
+          (+ *left-open-pos* (- *line-cache-length* *right-open-pos*)))
+         ((line-buffered-p ,line))
+         (t
+          (length (the simple-string (line-%chars ,line))))))

branches/ide-1.0/ccl/hemlock/src/linimage.lisp

@@ -339 +339 @@
 ;;;    Like compute-normal-line-image, only works on the cached line.
 ;;;
-(defun compute-cached-line-image (buffer index dis-line xpos width)
+(defun compute-cached-line-image (index dis-line xpos width)
   (declare (fixnum index width) (type (or fixnum null) xpos))
-  (prog ((gap (- (buffer-right-open-pos buffer) (buffer-left-open-pos buffer)))
+  (prog ((gap (- *right-open-pos* *left-open-pos*))
          (dest (dis-line-chars dis-line))
-         (done-p (= (buffer-right-open-pos buffer)
-                    (buffer-line-cache-length buffer)))
+         (done-p (= *right-open-pos* *line-cache-length*))
          (losing 0)
          string underhang)
@@ -355 +354 @@
      ((null xpos)
       (update-and-punt dis-line width nil 0 index))
-     ((>= index (buffer-left-open-pos buffer))
+     ((>= index *left-open-pos*)
       (go RIGHT-START)))
-    (setq losing (%fcwa (buffer-open-chars buffer) index (buffer-left-open-pos buffer) losing-char))
+    (setq losing (%fcwa *open-chars* index *left-open-pos* losing-char))
     (cond
      (losing
-      (display-some-chars (buffer-open-chars buffer) index losing dest xpos width nil)
+      (display-some-chars *open-chars* index losing dest xpos width nil)
       ;; If we we didn't wrap then display some losers...
       (if xpos
-          (display-losing-chars (buffer-open-chars buffer) index (buffer-left-open-pos buffer) dest xpos
+          (display-losing-chars *open-chars* index *left-open-pos* dest xpos
                                 width string underhang string-get-rep
-                                (and done-p (= index (buffer-left-open-pos buffer))))
+                                (and done-p (= index *left-open-pos*)))
           (update-and-punt dis-line width nil 0 index)))
      (t
-      (display-some-chars (buffer-open-chars buffer) index (buffer-left-open-pos buffer) dest xpos width done-p)))
+      (display-some-chars *open-chars* index *left-open-pos* dest xpos width done-p)))
     (go LEFT-LOOP)
 
@@ -379 +378 @@
      ((null xpos)
       (update-and-punt dis-line width nil 0 (- index gap)))
-     ((= index (buffer-line-cache-length buffer))
+     ((= index *line-cache-length*)
       (update-and-punt dis-line xpos nil nil (- index gap))))
-    (setq losing (%fcwa (buffer-open-chars buffer) index (buffer-line-cache-length buffer) losing-char))
+    (setq losing (%fcwa *open-chars* index *line-cache-length* losing-char))
     (cond
      (losing
-      (display-some-chars (buffer-open-chars buffer) index losing dest xpos width nil)
+      (display-some-chars *open-chars* index losing dest xpos width nil)
       (cond
        ;; Did we wrap?
@@ -390 +389 @@
         (update-and-punt dis-line width nil 0 (- index gap)))
        (t
-        (display-losing-chars (buffer-open-chars buffer) index (buffer-line-cache-length buffer) dest xpos
+        (display-losing-chars *open-chars* index *line-cache-length* dest xpos
                               width string underhang string-get-rep))))
      (t
-      (display-some-chars (buffer-open-chars buffer) index (buffer-line-cache-length buffer) dest xpos width t)))
-    (go RIGHT-LOOP)))
+      (display-some-chars *open-chars* index *line-cache-length* dest xpos width t)))
+    (go RIGHT-LOOP))) 
 
 
@@ -443 +442 @@
 ;;;
 (defun compute-line-image (string underhang line offset dis-line width)
-  (let* ((buffer (line-%buffer line)))
-    ;;
-    ;; Release any old font-changes.
-    (let ((changes (dis-line-font-changes dis-line)))
-      (when changes
-        (do ((prev changes current)
-             (current (font-change-next changes)
-                      (font-change-next current)))
-            ((null current)
-             (setf (dis-line-font-changes dis-line) nil)
-             (shiftf (font-change-next prev) *free-font-changes* changes))
-          (setf (font-change-mark current) nil))))
-    ;;
-    ;; If the line has any Font-Marks, add Font-Changes for them.
-    (let ((marks (line-marks line)))
-      (when (dolist (m marks nil)
-              (when (fast-font-mark-p m) (return t)))
-        (let ((prev nil))
-          ;;
-          ;; Find the last Font-Mark with charpos less than Offset.  If there is
-          ;; such a Font-Mark, then there is a font-change to this font at X = 0.
-          (let ((max -1)
-                (max-mark nil))
-            (dolist (m marks)
-              (when (fast-font-mark-p m)
-                (let ((charpos (mark-charpos m)))
-                  (when (and (< charpos offset) (> charpos max))
-                    (setq max charpos  max-mark m)))))
-            (when max-mark
-              (setq prev (alloc-font-change 0 (font-mark-font max-mark) max-mark))
-              (setf (dis-line-font-changes dis-line) prev)))
-          ;;
-          ;; Repeatedly scan through marks, adding a font-change for the
-          ;; smallest Font-Mark with a charpos greater than Bound, until
-          ;; we find no such mark.
-          (do ((bound (1- offset) min)
-               (min most-positive-fixnum most-positive-fixnum)
-               (min-mark nil nil))
-              (())
-            (dolist (m marks)
-              (when (fast-font-mark-p m)
-                (let ((charpos (mark-charpos m)))
-                  (when (and (> charpos bound) (< charpos min))
-                    (setq min charpos  min-mark m)))))
-            (unless min-mark (return nil))
-            (let ((len (if (eq line (buffer-open-line buffer))
+  ;;
+  ;; Release any old font-changes.
+  (let ((changes (dis-line-font-changes dis-line)))
+    (when changes
+      (do ((prev changes current)
+           (current (font-change-next changes)
+                    (font-change-next current)))
+          ((null current)
+           (setf (dis-line-font-changes dis-line) nil)
+           (shiftf (font-change-next prev) *free-font-changes* changes))
+        (setf (font-change-mark current) nil))))
+  ;;
+  ;; If the line has any Font-Marks, add Font-Changes for them.
+  (let ((marks (line-marks line)))
+    (when (dolist (m marks nil)
+            (when (fast-font-mark-p m) (return t)))
+      (let ((prev nil))
+        ;;
+        ;; Find the last Font-Mark with charpos less than Offset.  If there is
+        ;; such a Font-Mark, then there is a font-change to this font at X = 0.
+        (let ((max -1)
+              (max-mark nil))
+          (dolist (m marks)
+            (when (fast-font-mark-p m)
+              (let ((charpos (mark-charpos m)))
+                (when (and (< charpos offset) (> charpos max))
+                  (setq max charpos  max-mark m)))))
+          (when max-mark
+            (setq prev (alloc-font-change 0 (font-mark-font max-mark) max-mark))
+            (setf (dis-line-font-changes dis-line) prev)))
+        ;;
+        ;; Repeatedly scan through marks, adding a font-change for the
+        ;; smallest Font-Mark with a charpos greater than Bound, until
+        ;; we find no such mark.
+        (do ((bound (1- offset) min)
+             (min most-positive-fixnum most-positive-fixnum)
+             (min-mark nil nil))
+            (())
+          (dolist (m marks)
+            (when (fast-font-mark-p m)
+              (let ((charpos (mark-charpos m)))
+                (when (and (> charpos bound) (< charpos min))
+                  (setq min charpos  min-mark m)))))
+          (unless min-mark (return nil))
+          (let ((len (if (eq line *open-line*)
                          (cached-real-line-length line 10000 offset min)
                          (real-line-length line 10000 offset min))))
-              (when (< len width)
-                (let ((new (alloc-font-change
-                            (+ len
-                               (if string
+            (when (< len width)
+              (let ((new (alloc-font-change
+                          (+ len
+                             (if string
                                  (- (length (the simple-string string)) underhang)
                                  0))
-                            (font-mark-font min-mark)
-                            min-mark)))
-                  (if prev
+                          (font-mark-font min-mark)
+                          min-mark)))
+                (if prev
                     (setf (font-change-next prev) new)
                     (setf (dis-line-font-changes dis-line) new))
-                  (setq prev new))))))))
-    ;;
-    ;; Recompute the line image.
-    (cond
-      (string
-       (let ((len (strlen string))
-             (chars (dis-line-chars dis-line))
-             (xpos 0))
-         (declare (type (or fixnum null) xpos) (simple-string chars))
-         (display-some-chars string underhang len chars xpos width nil)
-         (cond
-           ((null xpos)
-            (values string underhang offset))      
-           ((eq line (buffer-open-line buffer))
-            (compute-cached-line-image buffer offset dis-line xpos width))
-           ((line-buffered-p line)
-            (compute-buffered-line-image line offset dis-line xpos width))
-           (t
-            (compute-normal-line-image line offset dis-line xpos width)))))
-      ((eq line (buffer-open-line buffer))
-       (compute-cached-line-image offset dis-line 0 width))
-      ((line-buffered-p line)
-       (compute-buffered-line-image line offset dis-line 0 width))
-      (t
-       (compute-normal-line-image line offset dis-line 0 width)))))
+                (setq prev new))))))))
+  ;;
+  ;; Recompute the line image.
+  (cond
+   (string
+    (let ((len (strlen string))
+          (chars (dis-line-chars dis-line))
+          (xpos 0))
+      (declare (type (or fixnum null) xpos) (simple-string chars))
+      (display-some-chars string underhang len chars xpos width nil)
+      (cond
+       ((null xpos)
+        (values string underhang offset))          
+       ((eq line *open-line*)
+        (compute-cached-line-image offset dis-line xpos width))
+       ((line-buffered-p line)
+        (compute-buffered-line-image line offset dis-line xpos width))
+       (t
+        (compute-normal-line-image line offset dis-line xpos width)))))
+   ((eq line *open-line*)
+    (compute-cached-line-image offset dis-line 0 width))
+   ((line-buffered-p line)
+    (compute-buffered-line-image line offset dis-line 0 width))
+   (t
+    (compute-normal-line-image line offset dis-line 0 width))))

branches/ide-1.0/ccl/hemlock/src/macros.lisp

@@ -255 +255 @@
              (push `(,name (copy-mark ,pos :temporary)) let-slots))))))
 
-#|SAve this shit in case we want WITH-MARKto no longer cons marks.
+#||SAve this shit in case we want WITH-MARKto no longer cons marks.
 (defconstant with-mark-total 50)
 (defvar *with-mark-free-marks* (make-array with-mark-total))
@@ -316 +316 @@
       (push mark (line-marks (mark-line mark))))
     mark))
-|#
-
+||#
+
+
+(defmacro use-buffer (buffer &body forms)
+  "Use-Buffer Buffer {Form}*
+  Has The effect of making Buffer the current buffer during the evaluation
+  of the Forms.  For restrictions see the manual."
+  (let ((gensym (gensym)))
+    `(let ((,gensym *current-buffer*)
+           (*current-buffer* ,buffer))
+      (unwind-protect
+           (progn
+             (use-buffer-set-up ,gensym)
+             ,@forms)
+        (use-buffer-clean-up ,gensym)))))
 
 

branches/ide-1.0/ccl/hemlock/src/search1.lisp

@@ -634 +634 @@
   If there is no match for the pattern then Mark is not modified and NIL
   is returned."
-  (close-line (line-%buffer (mark-line mark)))
+  (close-line)
   (multiple-value-bind (line start matched)
                        (funcall (search-pattern-search-function search-pattern)
@@ -650 +650 @@
   in the text starting at the given Mark.  If N is Nil, all occurrences 
   following the Mark are replaced."
-  (let* ((buffer (line-%buffer (mark-line mark))))
-    (close-line buffer)
-    (do* ((replacement (coerce replacement 'simple-string))
-          (new (length (the simple-string replacement)))
-          (fun (search-pattern-search-function search-pattern))
-          (forward-p (eq (search-pattern-direction search-pattern) :forward))
-          (n (if n (1- n) -1) (1- n))
-          (m (copy-mark mark :temporary)) line start matched)
-         (())
-      (multiple-value-setq (line start matched)
-        (funcall fun search-pattern (mark-line m) (mark-charpos m)))
-      (unless matched (return m))
-      (setf (mark-line m) line  (mark-charpos m) start)
-      (delete-characters m matched)
-      (insert-string m replacement)
-      (when forward-p (character-offset m new))
-      (when (zerop n) (return m))
-      (close-line buffer))))
+  (close-line)
+  (do* ((replacement (coerce replacement 'simple-string))
+        (new (length (the simple-string replacement)))
+        (fun (search-pattern-search-function search-pattern))
+        (forward-p (eq (search-pattern-direction search-pattern) :forward))
+        (n (if n (1- n) -1) (1- n))
+        (m (copy-mark mark :temporary)) line start matched)
+       (())
+    (multiple-value-setq (line start matched)
+      (funcall fun search-pattern (mark-line m) (mark-charpos m)))
+    (unless matched (return m))
+    (setf (mark-line m) line  (mark-charpos m) start)
+    (delete-characters m matched)
+    (insert-string m replacement)
+    (when forward-p (character-offset m new))
+    (when (zerop n) (return m))
+    (close-line)))

branches/ide-1.0/ccl/hemlock/src/struct.lisp

@@ -111 +111 @@
   (external-format :unix)     ; Line-termination, for the time being
   process                     ; Maybe a listener
-  (line-cache-length 200)     ; Length of string used for per-buffer gap.
-  (open-chars (make-string 200)) ; String used for per-buffer cache
-  (left-open-pos 0)           ; Index of first free character to left of
-                              ; gap in open-chars.
-  (right-open-pos 0)          ; Index of first used character to right of
-                              ; gap in open-chars
-  %open-line                  ; line which open-chars represent, or nil.
+  (gap-context )              ; The value of *buffer-gap-context*
+                              ; in the thread that can modify the buffer.
   protected-region            ; (optional) write-protected region
   (font-regions (ccl::init-dll-header (ccl::make-dll-header)))
                                         ; a doubly-linked list of font regions.
   active-font-region                    ; currently active font region
-  (lock (ccl:make-lock))
   )
 
@@ -685 +679 @@
    any buffer whose fields list contains the field.")
 
-
-
-(defun buffer-open-line (buffer)
-  (if (typep buffer 'buffer)
-    (buffer-%open-line buffer)))
-
-(defun (setf buffer-open-line) (line buffer)
-  (setf (buffer-%open-line buffer) line))
-
-
-
-
-
-             
+;;; Shared buffer-gap context, used to communicate between command threads
+;;; and the event thread.  Note that this isn't buffer-specific; in particular,
+;;; OPEN-LINE and friends may not point at a line that belongs to any
+;;; buffer.
+
+(defstruct buffer-gap-context
+  (lock (ccl::make-lock))
+  (left-open-pos 0)
+  (right-open-pos 0)
+  (line-cache-length 200)
+  (open-line nil)
+  (open-chars (make-string 200))
+)
+
+(define-symbol-macro *line-cache-length* (buffer-gap-context-line-cache-length *buffer-gap-context*))
+(define-symbol-macro *open-line* (buffer-gap-context-open-line *buffer-gap-context*))
+(define-symbol-macro *open-chars* (buffer-gap-context-open-chars *buffer-gap-context*))
+(define-symbol-macro *left-open-pos* (buffer-gap-context-left-open-pos *buffer-gap-context*))
+(define-symbol-macro *right-open-pos* (buffer-gap-context-right-open-pos *buffer-gap-context*))
+