- (if positive
- ;; Positive annotations are stacked, remembering location
- (setq open-ans (cons (list name loc) 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.
- (if (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.
- (while (not found)
- (let* ((top (car open-ans)) ; first on stack: should match.
- (top-name (car top))
- (start (car (cdr top))) ; location of start
- (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
- ;; Yes, use the current property name &
- ;; value. 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))
- (cond
- ;; Check for pseudo-properties
- ((eq prop 'PARAMETER)
- ;; This is 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 to call.
- (let ((rtn (apply value start loc params)))
- (if rtn (setq todo (cons rtn todo)))))
- (t
- ;; Normal property/value pair
- (setq todo
- (cons (list start loc prop value)
- todo)))))))
- (setq alist (cdr alist))))
- (setq aalist (cdr aalist)))
- (if matched
- nil
+ (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)