Changeset 12289


Ignore:
Timestamp:
Jun 24, 2009, 7:40:15 PM (10 years ago)
Author:
rme
Message:

insert-character, insert-string: reindent; add charprops support

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/cocoa-ide/hemlock/src/htext3.lisp

    r8428 r12289  
    4444
    4545
    46 (defun insert-character (mark character)
     46(defun insert-character (mark character &key (charprops :neighbor))
    4747  "Inserts the Character at the specified Mark."
    4848  (declare (type base-char character))
    4949  (let* ((line (mark-line mark))
     50         (charpos (mark-charpos mark))
    5051         (buffer (line-%buffer line)))
    5152    (modifying-buffer buffer
    52                       (modifying-line line mark)
    53                       (cond ((char= character #\newline)
    54                              (let* ((next (line-next line))
    55                                     (new-chars (subseq (the simple-string (current-open-chars))
    56                                                        0 (current-left-open-pos)))
    57                                     (new-line (make-line :%buffer buffer
    58                                                          :chars (next-cache-modification-tick)
    59                                                          :previous line
    60                                                          :next next)))
    61                                (maybe-move-some-marks (charpos line new-line) (current-left-open-pos)
    62                                                       (- charpos (current-left-open-pos)))
    63                                (setf (line-%chars line) new-chars)
    64                                (setf (line-next line) new-line)
    65                                (if next (setf (line-previous next) new-line))
    66                                (number-line new-line)
    67                                (setf (current-open-line) new-line
    68                                      (current-left-open-pos) 0)))
    69                             (t
    70                              (if (= (current-right-open-pos) (current-left-open-pos))
    71                                (grow-open-chars))
     53      (modifying-line line mark)
     54      (cond ((char= character #\newline)
     55             (let* ((next (line-next line))
     56                    (new-chars (subseq (the simple-string (current-open-chars))
     57                                       0 (current-left-open-pos)))
     58                    (new-line (make-line :%buffer buffer
     59                                         :chars (next-cache-modification-tick)
     60                                         :previous line
     61                                         :next next)))
     62
     63               ;; Do newlines get properties?  What if a charprops arg is
     64               ;; specified here?
     65               (multiple-value-bind (left right)
     66                                    (split-line-charprops line charpos)
     67                 (setf (line-charprops-changes line) left
     68                       (line-charprops-changes new-line) right))
     69
     70               (maybe-move-some-marks (charpos line new-line) (current-left-open-pos)
     71                                      (- charpos (current-left-open-pos)))
     72                 
     73               (setf (line-%chars line) new-chars)
     74               (setf (line-next line) new-line)
     75               (if next (setf (line-previous next) new-line))
     76               (number-line new-line)
     77               (setf (current-open-line) new-line
     78                     (current-left-open-pos) 0)))
     79            (t
     80             (if (= (current-right-open-pos) (current-left-open-pos))
     81               (grow-open-chars))
     82
     83             ;; Rule: when charprops is :neighbor, an inserted character
     84             ;; takes on on the properties of the preceding character,
     85             ;; unless the character is being inserted at the beginning of
     86             ;; a line, in which case it takes on the the properties of the
     87             ;; following character.
     88
     89             (if (eq charprops :neighbor)
     90               (if (start-line-p mark)
     91                 (adjust-charprops-changes (line-charprops-changes line) 0 1)
     92                 (adjust-charprops-changes (line-charprops-changes line) (1- charpos) 1))
     93               (let* ((next-props (next-charprops mark))
     94                      (prev-props (previous-charprops mark)))
     95                 (cond ((charprops-equal charprops prev-props)
     96                        (format t "~& prev props (~s) equal" prev-props)
     97                        (adjust-charprops-changes (line-charprops-changes line) (1- charpos) 1))
     98                       ((charprops-equal charprops next-props)
     99                        (format t "~& next props (~s) equal" next-props)
     100                        (adjust-charprops-changes (line-charprops-changes line) charpos 1))
     101                       (t
     102                        (format t "~& surrounding props (~s, ~s) not equal" prev-props next-props)
     103                        (adjust-charprops-changes (line-charprops-changes line) charpos 1)
     104                        (set-line-charprops line charprops :start charpos
     105                                        :end (1+ charpos))))))
     106
     107             (maybe-move-some-marks (charpos line) (current-left-open-pos)
     108                                    (1+ charpos))
    72109             
    73                              (maybe-move-some-marks (charpos line) (current-left-open-pos)
    74                                                     (1+ charpos))
    75              
    76                              (cond
    77                                ((eq (mark-%kind mark) :right-inserting)
    78                                 (decf (current-right-open-pos))
    79                                 (setf (char (the simple-string (current-open-chars)) (current-right-open-pos))
    80                                       character))
    81                                (t
    82                                 (setf (char (the simple-string (current-open-chars)) (current-left-open-pos))
    83                                       character)
    84                                 (incf (current-left-open-pos))))))
    85                       (adjust-line-origins-forward line)
    86                       (buffer-note-insertion buffer mark 1))))
    87 
    88 
    89 
    90 (defun insert-string (mark string #| &optional (start 0) (end (length string))|#)
    91   "Inserts the String at the Mark.  Do not use Start and End unless you
    92   know what you're doing!"
     110             (cond
     111              ((eq (mark-%kind mark) :right-inserting)
     112               (decf (current-right-open-pos))
     113               (setf (char (the simple-string (current-open-chars)) (current-right-open-pos))
     114                     character))
     115              (t
     116               (setf (char (the simple-string (current-open-chars)) (current-left-open-pos))
     117                     character)
     118               (incf (current-left-open-pos))))))
     119      (adjust-line-origins-forward line)
     120      (buffer-note-insertion buffer mark 1))))
     121
     122
     123
     124(defun insert-string (mark string &key (charprops :neighbor))
     125  "Inserts the String at the Mark."
    93126  (let* ((line (mark-line mark))
     127         (charpos (mark-charpos mark))
    94128         (len (length string))
    95129         (buffer (line-%buffer line))
     
    98132    (unless (zerop len)
    99133      (if (%sp-find-character string 0 len #\newline)
    100         (ninsert-region mark (string-to-region string))
    101         (modifying-buffer
    102          buffer
    103          (progn
    104            (modifying-line line mark)
    105            (if (<= (current-right-open-pos) (+ (current-left-open-pos) len))
    106              (grow-open-chars (* (+ (current-line-cache-length) len) 2)))
    107            (maybe-move-some-marks (charpos line) (current-left-open-pos)
    108                                   (+ charpos len))
    109            (cond
    110              ((eq (mark-%kind mark) :right-inserting)
    111               (let ((new (- (current-right-open-pos) len)))
    112                 (%sp-byte-blt string 0 (current-open-chars) new (current-right-open-pos))
    113                 (setf (current-right-open-pos) new)))
    114              (t
    115               (let ((new (+ (current-left-open-pos) len)))
    116                 (%sp-byte-blt string 0 (current-open-chars) (current-left-open-pos) new)
    117                 (setf (current-left-open-pos) new)))))
    118          (adjust-line-origins-forward line)
    119          (buffer-note-insertion buffer mark (length string)))))))
    120                        
    121  
    122 
     134        (progn
     135          (when (eq charprops :neighbor)
     136            (if (start-line-p mark)
     137              (setq charprops (next-charprops mark))
     138              (setq charprops (previous-charprops mark))))
     139          (ninsert-region mark (string-to-region string :charprops charprops)))
     140        (modifying-buffer buffer
     141          (modifying-line line mark)
     142          (if (<= (current-right-open-pos) (+ (current-left-open-pos) len))
     143            (grow-open-chars (* (+ (current-line-cache-length) len) 2)))
     144
     145          (if (eq charprops :neighbor)
     146            (if (start-line-p mark)
     147              (adjust-charprops-changes (line-charprops-changes line) 0 len)
     148              (adjust-charprops-changes (line-charprops-changes line) (1- charpos) len))
     149            (let* ((next-props (next-charprops mark))
     150                   (prev-props (previous-charprops mark)))
     151              (cond ((charprops-equal charprops prev-props)
     152                     (format t "~& prev props (~s) equal" prev-props)
     153                     (adjust-charprops-changes (line-charprops-changes line) (1- charpos) len))
     154                    ((charprops-equal charprops next-props)
     155                     (format t "~& next props (~s) equal" next-props)
     156                     (adjust-charprops-changes (line-charprops-changes line) charpos len))
     157                    (t
     158                     (format t "~& surrounding props (~s, ~s) not equal" prev-props next-props)
     159                     (set-line-charprops line charprops :start charpos
     160                                     :end (+ charpos len))))))
     161
     162          (maybe-move-some-marks (charpos line) (current-left-open-pos)
     163                                 (+ charpos len))
     164          (cond
     165           ((eq (mark-%kind mark) :right-inserting)
     166            (let ((new (- (current-right-open-pos) len)))
     167              (%sp-byte-blt string 0 (current-open-chars) new (current-right-open-pos))
     168              (setf (current-right-open-pos) new)))
     169           (t
     170            (let ((new (+ (current-left-open-pos) len)))
     171              (%sp-byte-blt string 0 (current-open-chars) (current-left-open-pos) new)
     172              (setf (current-left-open-pos) new))))
     173          (adjust-line-origins-forward line)
     174          (buffer-note-insertion buffer mark (length string)))))))
    123175
    124176
Note: See TracChangeset for help on using the changeset viewer.