1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
|
(rear-nonsticky (t "idsubscript1")
(t "subscript1")
(t "superscript1"))))
(defun format-deannotate-region (from to translations next-fn)
"Translate annotations in the region into text properties.
This sets text properties between FROM to TO as directed by the
TRANSLATIONS and NEXT-FN arguments.
NEXT-FN is a function that searches forward from point for an annotation.
It should return a list of 4 elements: \(BEGIN END NAME POSITIVE). BEGIN and
END are buffer positions bounding the annotation, NAME is the name searched
for in TRANSLATIONS, and POSITIVE should be non-nil if this annotation marks
the beginning of a region with some property, or nil if it ends the region.
NEXT-FN should return nil if there are no annotations after point.
The basic format of the TRANSLATIONS argument is described in the
documentation for the `format-annotate-region' function. There are some
additional things to keep in mind for decoding, though:
When an annotation is found, the TRANSLATIONS list is searched for a
text-property name and value that corresponds to that annotation. If the
text-property has several annotations associated with it, it will be used only
if the other annotations are also in effect at that point. The first match
found whose annotations are all present is used.
The text property thus determined is set to the value over the region between
the opening and closing annotations. However, if the text-property name has a
non-nil `format-list-valued' property, then the value will be consed onto the
surrounding value of the property, rather than replacing that value.
There are some special symbols that can be used in the \"property\" slot of
the TRANSLATIONS list: PARAMETER and FUNCTION \(spelled in uppercase).
Annotations listed under the pseudo-property PARAMETER are considered to be
arguments of the immediately surrounding annotation; the text between the
opening and closing parameter annotations is deleted from the buffer but saved
as a string.
The surrounding annotation should be listed under the pseudo-property
FUNCTION. Instead of inserting a text-property for this annotation,
the function listed in the VALUE slot is called to make whatever
changes are appropriate. It can also return a list of the form
\(START LOC PROP VALUE) which specifies a property to put on. The
function's first two arguments are the START and END locations, and
the rest of the arguments are any PARAMETERs found in that region.
Any annotations that are found by NEXT-FN but not defined by TRANSLATIONS
are saved as values of the `unknown' text-property \(which is list-valued).
The TRANSLATIONS list should usually contain an entry of the form
\(unknown \(nil format-annotate-value))
to write these unknown annotations back into the file."
(save-excursion
(save-restriction
(narrow-to-region (point-min) to)
(goto-char from)
(let (next open-ans todo loc unknown-ans)
(while (setq next (funcall next-fn))
(let* ((loc (nth 0 next))
(end (nth 1 next))
(name (nth 2 next))
(positive (nth 3 next))
(found nil))
;; Delete the annotation
(delete-region loc end)
(cond
;; Positive annotations are stacked, remembering location
(positive (push `(,name ((,loc . nil))) open-ans))
;; It is a negative annotation:
;; Close the top annotation & add its text property.
;; If the file's nesting is messed up, the close might not match
;; the top thing on the open-annotations stack.
;; If no matching annotation is open, just ignore the close.
((not (assoc name open-ans))
(message "Extra closing annotation (%s) in file" name))
;; If one is open, but not on the top of the stack, close
;; the things in between as well. Set `found' when the real
;; one is closed.
(t
(while (not found)
(let* ((top (car open-ans)) ; first on stack: should match.
(top-name (car top)) ; text property name
(top-extents (nth 1 top)) ; property regions
(params (cdr (cdr top))) ; parameters
(aalist translations)
(matched nil))
(if (equal name top-name)
(setq found t)
(message "Improper nesting in file."))
;; Look through property names in TRANSLATIONS
(while aalist
(let ((prop (car (car aalist)))
(alist (cdr (car aalist))))
;; And look through values for each property
(while alist
(let ((value (car (car alist)))
(ans (cdr (car alist))))
(if (member top-name ans)
;; This annotation is listed, but still have to
;; check if multiple annotations are satisfied
(if (member nil (mapcar (lambda (r)
(assoc r open-ans))
ans))
nil ; multiple ans not satisfied
;; If there are multiple annotations going
;; into one text property, split up the other
;; annotations so they apply individually to
;; the other regions.
(setcdr (car top-extents) loc)
(let ((to-split ans) this-one extents)
(while to-split
(setq this-one
(assoc (car to-split) open-ans)
extents (nth 1 this-one))
(if (not (eq this-one top))
(setcar (cdr this-one)
(format-subtract-regions
extents top-extents)))
(setq to-split (cdr to-split))))
;; Set loop variables to nil so loop
;; will exit.
(setq alist nil aalist nil matched t
;; pop annotation off stack.
open-ans (cdr open-ans))
(let ((extents top-extents)
(start (car (car top-extents)))
(loc (cdr (car top-extents))))
(while extents
(cond
;; Check for pseudo-properties
((eq prop 'PARAMETER)
;; A parameter of the top open ann:
;; delete text and use as arg.
(if open-ans
;; (If nothing open, discard).
(setq open-ans
(cons
(append (car open-ans)
(list
(buffer-substring
start loc)))
(cdr open-ans))))
(delete-region start loc))
((eq prop 'FUNCTION)
;; Not a property, but a function.
(let ((rtn
(apply value start loc params)))
(if rtn (push rtn todo))))
(t
;; Normal property/value pair
(setq todo
(cons (list start loc prop value)
todo))))
(setq extents (cdr extents)
start (car (car extents))
loc (cdr (car extents))))))))
(setq alist (cdr alist))))
(setq aalist (cdr aalist)))
(if (not matched)
;; Didn't find any match for the annotation:
;; Store as value of text-property `unknown'.
(let ((extents top-extents)
(start (car (car top-extents)))
(loc (or (cdr (car top-extents)) loc)))
(while extents
(setq open-ans (cdr open-ans)
todo (cons (list start loc 'unknown top-name)
todo)
unknown-ans (cons name unknown-ans)
extents (cdr extents)
start (car (car extents))
loc (cdr (car extents))))))))))))
;; Once entire file has been scanned, add the properties.
(while todo
(let* ((item (car todo))
(from (nth 0 item))
(to (nth 1 item))
(prop (nth 2 item))
(val (nth 3 item)))
(if (numberp val) ; add to ambient value if numeric
(format-property-increment-region from to prop val 0)
(put-text-property
from to prop
(cond ((get prop 'format-list-valued) ; value gets consed onto
; list-valued properties
(let ((prev (get-text-property from prop)))
(cons val (if (listp prev) prev (list prev)))))
(t val))))) ; normally, just set to val.
(setq todo (cdr todo)))
(if unknown-ans
(message "Unknown annotations: %s" unknown-ans))))))
|
