3 (defvar *inhibit-point-motion-hooks
* nil
4 "If non-nil, don't run `point-left' and `point-entered' text properties.
5 This also inhibits the use of the `intangible' text property.")
7 ;; This function is not translated well
8 (defun validate-interval-range (object begin end force
)
10 ;; /* If we are asked for a point, but from a subr which operates
11 ;; on a range, then return nothing. */
12 ;; if (EQ (*begin, *end) && begin != end)
13 ;; return NULL_INTERVAL;
19 (when (not (and (<= (buffer-min object
) begin
)
21 (<= end
(buffer-max object
))))
22 (signal 'args-out-of-range
))
23 (setf i
(intervals object
))
24 (when (= (buffer-min object
) (buffer-max object
))
25 (return-from validate-interval-range
(values nil begin end
)))
26 (setf searchpos begin
))
28 (let ((len (length (pstring-data object
))))
29 (when (not (and (<= 0 begin
)
32 (signal 'args-out-of-range
))
33 (setf i
(intervals object
))
35 (return-from validate-interval-range
(values nil begin end
)))
36 (setf searchpos begin
)))
38 (return-from validate-interval-range
39 (values nil
(max 0 begin
) (min (length object
) end
)))))
41 (values (find-interval i searchpos
) begin end
)
43 (values (create-root-interval object
) begin end
)
44 (values i begin end
)))))
46 (defun validate-plist (list)
47 "/* Validate LIST as a property list. If LIST is not a list, then
48 make one consisting of (LIST nil). Otherwise, verify that LIST is
49 even numbered and thus suitable as a plist. */"
50 (cond ((null list
) nil
)
52 (if (oddp (length list
))
53 (error "odd length property list")
55 (t (list (list list nil
)))))
57 (defun set-text-properties (start end properties
&optional
(object (current-buffer)))
58 (let ((start-bk start
)
61 (setf properties
(validate-plist properties
))
62 ;; If we want no properties for a whole string, get rid of its
64 (when (and (null properties
)
65 (typep object
'pstring
)
67 (= end
(length (pstring-data object
))))
68 (when (null (intervals object
))
69 (return-from set-text-properties t
))
70 (setf (intervals object
) nil
)
71 (return-from set-text-properties t
))
72 (multiple-value-setq (i start end
)
73 (validate-interval-range object start end nil
))
75 (when (null properties
)
76 (return-from set-text-properties nil
))
77 ;; /* Restore the original START and END values because
78 ;; validate_interval_range increments them for strings. */
81 (multiple-value-setq (i start end
)
82 (validate-interval-range object start end t
))
83 ;; /* This can return if start == end. */
85 (return-from set-text-properties nil
)))
88 ;; (when (typep object 'buffer)
89 ;; ;; modify_region (XBUFFER (object), XINT (start), XINT (end));
90 (set-text-properties-1 start end properties object i
)
92 ;; if (BUFFERP (object) && !NILP (signal_after_change_p))
93 ;; signal_after_change (XINT (start), XINT (end) - XINT (start),
94 ;; XINT (end) - XINT (start));
97 (defun add-properties (plist i object
)
98 "Add the properties in plist to interval I. OBJECT should be the
99 string of buffer containing the interval."
100 (declare (ignore object
))
102 (doplist (sym val plist changed
)
103 (let ((found (getf (interval-plist i
) sym
)))
106 ;; record-property-change
107 (when (not (eql found val
))
108 (setf (getf (interval-plist i
) sym
) val
111 ;; record-property-change
112 (setf (getf (interval-plist i
) sym
) val
115 (defun interval-has-all-properties (plist i
)
116 "/* Return nonzero if interval I has all the properties, with the same
117 values, of list PLIST. */"
118 (doplist (sym val plist t
)
119 (let ((found (getf (interval-plist i
) sym
)))
121 (when (not (eql found val
))
122 (return-from interval-has-all-properties nil
))
123 (return-from interval-has-all-properties nil
)))))
125 (defun add-text-properties (start end properties
&optional
(object (current-buffer)))
126 "Add properties to the text from START to END. The third argument
127 PROPERTIES is a property list specifying the property values to add.
128 If the optional fourth argument OBJECT is a buffer (or nil, which
129 means the current buffer), START and END are buffer positions
130 (integers or markers). If OBJECT is a string, START and END are
131 0-based indices into it. Return t if any property value actually
132 changed, nil otherwise."
133 (let ((len (- end start
))
136 (setf properties
(validate-plist properties
))
137 (when (null properties
)
138 (return-from add-text-properties nil
))
139 (multiple-value-setq (i start end
) (validate-interval-range object start end t
))
141 (return-from add-text-properties nil
))
142 ;; If we're not starting on an interval boundary, we have to split
144 (when (/= (interval-pt i
) start
)
145 (if (interval-has-all-properties properties i
)
146 (let ((got (- (interval-text-length i
) (- start
(interval-pt i
)))))
148 (return-from add-text-properties nil
))
150 (setf i
(next-interval i
)))
153 (setf i
(split-interval-right unchanged
(- start
(interval-pt unchanged
))))
154 (copy-properties unchanged i
))))
155 ;; if (BUFFERP (object))
156 ;; modify_region (XBUFFER (object), XINT (start), XINT (end));
158 ;; We are at the beginning of interval I, with LEN chars to scan.
162 (when (>= (interval-text-length i
) len
)
163 (when (interval-has-all-properties properties i
)
164 (return-from add-text-properties modified
))
165 (when (= (interval-text-length i
) len
)
166 (add-properties properties i object
)
167 (return-from add-text-properties t
))
169 i
(split-interval-left unchanged len
))
170 (copy-properties unchanged i
)
171 (add-properties properties i object
)
172 (return-from add-text-properties t
))
173 (decf len
(interval-text-length i
))
174 (setf modified
(add-properties properties i object
)
175 i
(next-interval i
)))))
177 (defun put-text-property (start end property value object
)
178 "Set one property of the text from START to END. The third and
179 fourth arguments PROPERTY and VALUE specify the property to add. If
180 the optional fifth argument OBJECT is a buffer (or nil, which means
181 the current buffer), START and END are buffer positions (integers or
182 markers). If OBJECT is a string, START and END are 0-based indices
184 (add-text-properties start end
(list property value
) object
))
186 (defun remove-properties (plist list i object
)
187 (declare (ignore object
))
188 (doplist (sym val plist
)
189 (declare (ignore val
))
190 (remf sym
(interval-plist i
)))
192 (remf sym
(interval-plist i
))))
194 (defun remove-text-properties (start end properties
&optional
(object (current-buffer)))
195 "Remove some properties from text from START to END. The third
196 argument PROPERTIES is a property list whose property names specify
197 the properties to remove. \(The values stored in PROPERTIES are
198 ignored.) If the optional fourth argument OBJECT is a buffer (or nil,
199 which means the current buffer), START and END are buffer positions
200 (integers or markers). If OBJECT is a string, START and END are
201 0-based indices into it. Return t if any property was actually
202 removed, nil otherwise.
204 Use set-text-properties if you want to remove all text properties."
205 (let (i unchanged len
(modified nil
))
206 (multiple-value-setq (i start end
)
207 (validate-interval-range object start end nil
))
209 (return-from remove-text-properties nil
))
210 (setf len
(- end start
))
211 (when (/= (interval-pt i
) start
)
212 (if (not (interval-has-all-properties properties i
))
213 (let ((got (- (interval-text-length i
) (- start
(interval-pt i
)))))
215 (return-from remove-text-properties nil
))
217 (setf i
(next-interval i
)))
220 i
(split-interval-right unchanged
(- start
(interval-pt unchanged
))))
221 (copy-properties unchanged i
))))
225 (when (>= (interval-text-length i
) len
)
226 (unless (interval-has-all-properties properties i
)
227 (return-from remove-text-properties modified
))
228 (when (= (interval-text-length i
) len
)
229 (remove-properties properties nil i object
)
230 (return-from remove-text-properties t
))
232 i
(split-interval-left i len
))
233 (copy-properties unchanged i
)
234 (remove-properties properties nil i object
)
235 (return-from remove-text-properties t
))
236 (decf len
(interval-text-length i
))
237 (setf modified
(remove-properties properties nil i object
)
238 i
(next-interval i
)))))
240 (defun text-properties-at (position &optional
(object (current-buffer)))
241 (multiple-value-bind (i position
) (validate-interval-range object position position t
)
243 ;; If POSITION is at the end of the interval,
244 ;; it means it's the end of OBJECT.
245 ;; There are no properties at the very end,
246 ;; since no character follows.
247 (unless (= position
(+ (interval-text-length i
) (interval-pt i
)))
248 (interval-plist i
)))))
250 (defun get-text-property (position prop
&optional
(object (current-buffer)))
251 (getf (text-properties-at position object
) prop
))
253 (defun get-char-property-and-overlay (position prop object overlay
)
254 (declare (ignore overlay
))
255 (get-text-property position prop object
))
257 (defun get-char-property (position prop
&optional
(object (current-buffer)))
258 (get-char-property-and-overlay position prop object
0))
260 (defun previous-property-change (position &optional
(object (current-buffer)) limit
)
261 "Return the position of previous property change.
262 Scans characters backwards from POSITION in OBJECT till it finds
263 a change in some text property, then returns the position of the change.
264 If the optional second argument OBJECT is a buffer (or nil, which means
265 the current buffer), POSITION is a buffer position (integer or marker).
266 If OBJECT is a string, POSITION is a 0-based index into it.
267 Return nil if the property is constant all the way to the start of OBJECT.
268 If the value is non-nil, it is a position less than POSITION, never equal.
270 If the optional third argument LIMIT is non-nil, don't search
271 back past position LIMIT; return LIMIT if nothing is found until LIMIT."
273 (multiple-value-setq (i position
) (validate-interval-range object position position nil
))
275 (return-from previous-property-change limit
))
276 (when (= (interval-pt i
) position
)
277 (setf i
(previous-interval i
)))
278 (setf previous
(previous-interval i
))
280 (intervals-equal previous i
)
282 (> (+ (interval-pt previous
)
283 (interval-text-length previous
))
285 (setf previous
(previous-interval previous
)))
286 ;; FIXME: this code needs cleaning
287 (when (null previous
)
288 (return-from previous-property-change limit
))
289 (setf limit
(or limit
290 (cond ((typep object
'pstring
) 0)
291 ((typep object
'buffer
) (buffer-min object
)))))
292 (when (<= (+ (interval-pt previous
) (interval-text-length previous
))
294 (return-from previous-property-change limit
))
295 (+ (interval-pt previous
) (interval-text-length previous
))))
297 (defun next-property-change (position &optional object limit
)
298 "Return the position of next property change.
299 Scans characters forward from POSITION in OBJECT till it finds
300 a change in some text property, then returns the position of the change.
301 If the optional second argument OBJECT is a buffer (or nil, which means
302 the current buffer), POSITION is a buffer position (integer or marker).
303 If OBJECT is a string, POSITION is a 0-based index into it.
304 Return nil if the property is constant all the way to the end of OBJECT.
305 If the value is non-nil, it is a position greater than POSITION, never equal.
307 If the optional third argument LIMIT is non-nil, don't search
308 past position LIMIT; return LIMIT if nothing is found before LIMIT."
310 (multiple-value-setq (i position
) (validate-interval-range object position position nil
))
312 (setf next
(if (null i
)
315 (setf position
(if (null next
)
316 (cond ((typep object
'pstring
) (pstring-length object
))
317 ((typep object
'buffer
) (buffer-max object
)))
319 (return-from next-property-change position
))
322 (return-from next-property-change limit
))
323 (setf next
(next-interval i
))
325 (intervals-equal i next
)
327 (< (interval-pt next
)
329 (setf next
(next-interval next
)))
331 (return-from next-property-change limit
))
333 (setf limit
(cond ((typep object
'pstring
) (pstring-length object
))
334 ((typep object
'buffer
) (buffer-max object
)))))
335 (unless (< (interval-pt next
) limit
)
336 (return-from next-property-change limit
))
337 ;; FIXME: This is silly code.
338 (setf position
(interval-pt next
))
341 (defun next-char-property-change (position &optional limit
(buffer (current-buffer)))
342 "Return the position of next text property or overlay change.
343 This scans characters forward in the current buffer from POSITION till
344 it finds a change in some text property, or the beginning or end of an
345 overlay, and returns the position of that.
346 If none is found, the function returns (point-max).
348 If the optional third argument LIMIT is non-nil, don't search
349 past position LIMIT; return LIMIT if nothing is found before LIMIT."
350 ;; temp = Fnext_overlay_change (position);
351 (next-property-change position buffer
(or limit
(buffer-max buffer
))))
353 (defun next-single-property-change (position prop
&optional
(object (current-buffer)) limit
)
354 (let (i next here-val
)
355 (multiple-value-setq (i position
)
356 (validate-interval-range object position position nil
))
358 (return-from next-single-property-change limit
))
359 (setf here-val
(getf (interval-plist i
) prop
)
360 next
(next-interval i
))
361 ;; walk the intervals til we find one with a different plist val
364 (eql here-val
(getf (interval-plist next
) prop
))
366 (< (interval-pt next
) limit
)))
367 (setf next
(next-interval next
)))
368 ;; FIXME: this code should be cleaned.
370 (return-from next-single-property-change limit
))
371 (setf limit
(or limit
372 (cond ((typep object
'pstring
) (pstring-length object
))
373 ((typep object
'buffer
) (buffer-max object
)))))
374 (when (>= (interval-pt next
) limit
)
375 (return-from next-single-property-change limit
))
378 (defun previous-single-property-change (position prop
&optional
(object (current-buffer)) limit
)
379 (let (i previous here-val
)
380 (multiple-value-setq (i position
) (validate-interval-range object position position nil
))
382 (= (interval-pt i
) position
))
383 (setf i
(previous-interval i
)))
385 (return-from previous-single-property-change limit
))
386 (setf here-val
(getf (interval-plist i
) prop
)
387 previous
(previous-interval i
))
389 (eql here-val
(getf (interval-plist previous
) prop
))
391 (> (+ (interval-pt previous
) (interval-text-length previous
))
393 (setf previous
(previous-interval previous
)))
394 ;; FIXME: this code should be cleaned.
395 (when (null previous
)
396 (return-from previous-single-property-change limit
))
397 (setf limit
(or limit
398 (cond ((typep object
'pstring
) 0)
399 ((typep object
'buffer
) (buffer-min object
)))))
400 (when (<= (+ (interval-pt previous
) (interval-text-length previous
))
402 (return-from previous-single-property-change limit
))
403 (+ (interval-pt previous
) (interval-text-length previous
))))
405 (defun previous-char-property-change (position &optional limit
(buffer (current-buffer)))
406 "Return the position of previous text property or overlay change.
407 Scans characters backward in the current buffer from POSITION till it
408 finds a change in some text property, or the beginning or end of an
409 overlay, and returns the position of that.
410 If none is found, the function returns (point-max).
412 If the optional third argument LIMIT is non-nil, don't search
413 past position LIMIT; return LIMIT if nothing is found before LIMIT."
414 (previous-property-change position buffer
(or limit
(buffer-min buffer
))))
416 (defun next-single-char-property-change (position prop
&optional
(object (current-buffer)) limit
)
417 "/* Return the position of next text property or overlay change for a specific property.
418 Scans characters forward from POSITION till it finds
419 a change in the PROP property, then returns the position of the change.
420 If the optional third argument OBJECT is a buffer (or nil, which means
421 the current buffer), POSITION is a buffer position (integer or marker).
422 If OBJECT is a string, POSITION is a 0-based index into it.
424 The property values are compared with `eql' by default.
425 If the property is constant all the way to the end of OBJECT, return the
426 last valid position in OBJECT.
427 If the optional fourth argument LIMIT is non-nil, don't search
428 past position LIMIT; return LIMIT if nothing is found before LIMIT. */"
429 (if (typep object
'pstring
)
431 (setf position
(next-single-property-change position prop object limit
))
434 (setf position
(pstring-length object
))
435 (setf position limit
))))
436 (let ((initial-value (get-char-property position prop object
))
438 ;; (when (and (typep object 'buffer)
439 ;; (not (eq object (current-buffer))))
442 (setf limit
(buffer-max object
)))
444 (setf position
(next-char-property-change position limit object
))
445 (when (>= position limit
)
447 (setf value
(get-char-property position prop object
))
448 (unless (eq value initial-value
)
449 (return position
))))))
451 (defun previous-single-char-property-change (position prop
&optional
(object (current-buffer)) limit
)
452 (cond ((typep object
'pstring
)
453 (setf position
(previous-single-property-change position prop object limit
))
454 (when (null position
)
455 (setf position
(or limit
456 (pstring-length object
)))))
459 (setf limit
(buffer-min object
)))
460 (if (<= position limit
)
461 (setf position limit
)
462 (let ((initial-value (get-char-property (1- position
) prop object
))
465 (setf position
(previous-char-property-change position limit object
))
466 (when (<= position limit
)
468 (setf value
(get-char-property (1- position
) prop object
))
469 (unless (eq value initial-value
)
470 (return position
))))))))
472 (defun text-property-stickiness (prop pos
&optional
(buffer (current-buffer)))
473 "Return the direction from which the text-property PROP would be
474 inherited by any new text inserted at POS: AFTER if it would be
475 inherited from the char after POS, BEFORE if it would be inherited from
476 the char before POS, and NIL if from neither.
477 BUFFER can be either a buffer or nil (meaning current buffer)."
478 (labels ((tmem (sym set
)
479 ;; Test for membership, allowing for t (actually any
480 ;; non-cons) to mean the universal set."
484 (let ((is-rear-sticky t
)
485 (is-front-sticky nil
)
486 prev-pos front-sticky
)
487 (when (> pos
(begv buffer
))
488 ;; Consider previous character.
489 (setf prev-pos
(1- pos
))
490 (let ((rear-non-sticky (get-text-property prev-pos
'rear-nonsticky buffer
)))
491 (when (tmem prop rear-non-sticky
)
492 ;; PROP is rear-non-sticky
493 (setf is-rear-sticky nil
))))
494 ;; Consider following character.
495 (setf front-sticky
(get-text-property pos
'front-sticky buffer
))
496 (when (or (eq front-sticky t
)
497 (and (consp front-sticky
)
498 (find prop front-sticky
)))
499 ;; PROP is inherited from after
500 (setf is-front-sticky t
))
503 ;; Simple cases, where the properties are consistent.
505 (not is-front-sticky
))
507 ((and (not is-rear-sticky
)
510 ((and (not is-rear-sticky
)
511 (not is-front-sticky
))
513 ((or (= pos
(begv buffer
))
514 (null (get-text-property prev-pos prop buffer
)))
519 (defun remove-list-of-text-properties (start end list-of-properties
&optional object
)
520 "Remove some properties from text from START to END.
521 The third argument LIST-OF-PROPERTIES is a list of property names to remove.
522 If the optional fourth argument OBJECT is a buffer (or nil, which means
523 the current buffer), START and END are buffer positions (integers or
524 markers). If OBJECT is a string, START and END are 0-based indices into it.
525 Return t if any property was actually removed, nil otherwise."
526 (declare (ignore start and list-of-properties object
))
527 (error "unimplemented"))
530 (provide :lice-0.1
/textprop
)