aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorRichard M. Stallman1997-05-31 01:37:15 +0000
committerRichard M. Stallman1997-05-31 01:37:15 +0000
commite5dfabb4897fc40ec5f3a282981f40b3e8049539 (patch)
tree7b2887acf205009bbc8df7dc12c76c618dc27076
parent6d1ab9d4d67b291df337a404a93fd065bf426359 (diff)
downloademacs-e5dfabb4897fc40ec5f3a282981f40b3e8049539.tar.gz
emacs-e5dfabb4897fc40ec5f3a282981f40b3e8049539.zip
(widget-default-format-handler): Don't use push.
(widget-push-button-value-create): Likewise. (widget-group-value-create): Likewise. (widget-sublist): New function. (widget-item-match-inline): Use widget-subllist. (widget-remove-if): New function. (widget-choose): Use widget-remove-if.
-rw-r--r--lisp/wid-edit.el73
1 files changed, 48 insertions, 25 deletions
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index 561c7efb42b..6de406f4c4c 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -31,7 +31,6 @@
31;;; Code: 31;;; Code:
32 32
33(require 'widget) 33(require 'widget)
34(require 'cl)
35 34
36;;; Compatibility. 35;;; Compatibility.
37 36
@@ -225,7 +224,7 @@ minibuffer."
225 (car (event-object val)))) 224 (car (event-object val))))
226 (cdr (assoc val items)))) 225 (cdr (assoc val items))))
227 (t 226 (t
228 (setq items (remove-if 'stringp items)) 227 (setq items (widget-remove-if 'stringp items))
229 (let ((val (completing-read (concat title ": ") items nil t))) 228 (let ((val (completing-read (concat title ": ") items nil t)))
230 (if (stringp val) 229 (if (stringp val)
231 (let ((try (try-completion val items))) 230 (let ((try (try-completion val items)))
@@ -234,6 +233,14 @@ minibuffer."
234 (cdr (assoc val items))) 233 (cdr (assoc val items)))
235 nil))))) 234 nil)))))
236 235
236(defun widget-remove-if (predictate list)
237 (let (result (tail list))
238 (while tail
239 (or (funcall predictate (car tail))
240 (setq result (cons (car tail) result)))
241 (setq tail (cdr tail)))
242 (nreverse result)))
243
237;;; Widget text specifications. 244;;; Widget text specifications.
238;; 245;;
239;; These functions are for specifying text properties. 246;; These functions are for specifying text properties.
@@ -1306,19 +1313,20 @@ Optional EVENT is the event that triggered the action."
1306 ;; Get rid of trailing newlines. 1313 ;; Get rid of trailing newlines.
1307 (when (string-match "\n+\\'" doc-text) 1314 (when (string-match "\n+\\'" doc-text)
1308 (setq doc-text (substring doc-text 0 (match-beginning 0)))) 1315 (setq doc-text (substring doc-text 0 (match-beginning 0))))
1309 (push (if (string-match "\n." doc-text) 1316 (setq buttons
1310 ;; Allow multiline doc to be hiden. 1317 (cons (if (string-match "\n." doc-text)
1311 (widget-create-child-and-convert 1318 ;; Allow multiline doc to be hiden.
1312 widget 'widget-help 1319 (widget-create-child-and-convert
1313 :doc (progn 1320 widget 'widget-help
1314 (string-match "\\`.*" doc-text) 1321 :doc (progn
1315 (match-string 0 doc-text)) 1322 (string-match "\\`.*" doc-text)
1316 :widget-doc doc-text 1323 (match-string 0 doc-text))
1317 "?") 1324 :widget-doc doc-text
1318 ;; A single line is just inserted. 1325 "?")
1319 (widget-create-child-and-convert 1326 ;; A single line is just inserted.
1320 widget 'item :format "%d" :doc doc-text nil)) 1327 (widget-create-child-and-convert
1321 buttons))) 1328 widget 'item :format "%d" :doc doc-text nil))
1329 buttons))))
1322 (t 1330 (t
1323 (error "Unknown escape `%c'" escape))) 1331 (error "Unknown escape `%c'" escape)))
1324 (widget-put widget :buttons buttons))) 1332 (widget-put widget :buttons buttons)))
@@ -1423,9 +1431,22 @@ Optional EVENT is the event that triggered the action."
1423 (let ((value (widget-get widget :value))) 1431 (let ((value (widget-get widget :value)))
1424 (and (listp value) 1432 (and (listp value)
1425 (<= (length value) (length values)) 1433 (<= (length value) (length values))
1426 (let ((head (subseq values 0 (length value)))) 1434 (let ((head (widget-sublist values 0 (length value))))
1427 (and (equal head value) 1435 (and (equal head value)
1428 (cons head (subseq values (length value)))))))) 1436 (cons head (widget-sublist values (length value))))))))
1437
1438(defun widget-sublist (list start &optional end)
1439 "Return the sublist of LIST from START to END.
1440If END is omitted, it defaults to the length of LIST."
1441 (let (len)
1442 (if (> start 0) (setq list (nthcdr start list)))
1443 (if end
1444 (if (<= end start)
1445 nil
1446 (setq list (copy-sequence list))
1447 (setcdr (nthcdr (- end start 1) list) nil)
1448 list)
1449 (copy-sequence list))))
1429 1450
1430(defun widget-item-action (widget &optional event) 1451(defun widget-item-action (widget &optional event)
1431 ;; Just notify itself. 1452 ;; Just notify itself.
@@ -1474,7 +1495,8 @@ Optional EVENT is the event that triggered the action."
1474 (progn 1495 (progn
1475 (unless gui 1496 (unless gui
1476 (setq gui (make-gui-button tag 'widget-gui-action widget)) 1497 (setq gui (make-gui-button tag 'widget-gui-action widget))
1477 (push (cons tag gui) widget-push-button-cache)) 1498 (setq widget-push-button-cache
1499 (cons (cons tag gui) widget-push-button-cache)))
1478 (widget-glyph-insert-glyph widget 1500 (widget-glyph-insert-glyph widget
1479 (make-glyph 1501 (make-glyph
1480 (list (nth 0 (aref gui 1)) 1502 (list (nth 0 (aref gui 1))
@@ -2429,13 +2451,14 @@ when he invoked the menu."
2429 (and (eq (preceding-char) ?\n) 2451 (and (eq (preceding-char) ?\n)
2430 (widget-get widget :indent) 2452 (widget-get widget :indent)
2431 (insert-char ? (widget-get widget :indent))) 2453 (insert-char ? (widget-get widget :indent)))
2432 (push (cond ((null answer) 2454 (setq children
2433 (widget-create-child widget arg)) 2455 (cons (cond ((null answer)
2434 ((widget-get arg :inline) 2456 (widget-create-child widget arg))
2435 (widget-create-child-value widget arg (car answer))) 2457 ((widget-get arg :inline)
2436 (t 2458 (widget-create-child-value widget arg (car answer)))
2437 (widget-create-child-value widget arg (car (car answer))))) 2459 (t
2438 children)) 2460 (widget-create-child-value widget arg (car (car answer)))))
2461 children)))
2439 (widget-put widget :children (nreverse children)))) 2462 (widget-put widget :children (nreverse children))))
2440 2463
2441(defun widget-group-match (widget values) 2464(defun widget-group-match (widget values)