Mercurial > hg > xemacs-beta

comparison lisp/list-mode.el @ 5330:fbafdc1bb4d2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Use defun*, not cl-parsing-keywords, #'make-dialog-box, #'display-completion-list lisp/ChangeLog addition: 2011-01-02 Aidan Kehoe <kehoea@parhasard.net> * dialog.el (make-dialog-box): * list-mode.el (display-completion-list): These functions used to use cl-parsing-keywords; change them to use defun* instead, fixing the build. (Not sure what led to me not including this change in d1b17a33450b!)
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 02 Jan 2011 17:04:13 +0000
parents ea07b60c097f
children 89331fa1c819
comparison
equal deleted inserted replaced
5329:7b391d07b334 5330:fbafdc1bb4d2
274 "Type \\<minibuffer-local-completion-map>\\[advertised-switch-to-completions] or \\[switch-to-completions] to move to this buffer, for keyboard selection.\n\n")) 274 "Type \\<minibuffer-local-completion-map>\\[advertised-switch-to-completions] or \\[switch-to-completions] to move to this buffer, for keyboard selection.\n\n"))
275 "Form the evaluate to get a help string for completion lists. 275 "Form the evaluate to get a help string for completion lists.
276 This string is inserted at the beginning of the buffer. 276 This string is inserted at the beginning of the buffer.
277 See `display-completion-list'.") 277 See `display-completion-list'.")
278 278
279 (defun display-completion-list (completions &rest cl-keys) 279 (defun* display-completion-list (completions &key user-data reference-buffer
280 (activate-callback 'default-choose-completion)
281 (help-string completion-default-help-string)
282 (completion-string "Possible completions are:")
283 window-width window-height)
280 "Display the list of completions, COMPLETIONS, using `standard-output'. 284 "Display the list of completions, COMPLETIONS, using `standard-output'.
281 Each element may be just a symbol or string or may be a list of two 285 Each element may be just a symbol or string or may be a list of two
282 strings to be printed as if concatenated. 286 strings to be printed as if concatenated.
283 Frob a mousable extent onto each completion. This extent has properties 287 Frob a mousable extent onto each completion. This extent has properties
284 'mouse-face (so it highlights when the mouse passes over it) and 288 'mouse-face (so it highlights when the mouse passes over it) and
308 312
309 At the end, run the normal hook `completion-setup-hook'. 313 At the end, run the normal hook `completion-setup-hook'.
310 It can find the completion buffer in `standard-output'. 314 It can find the completion buffer in `standard-output'.
311 If `completion-highlight-first-word-only' is non-nil, then only the start 315 If `completion-highlight-first-word-only' is non-nil, then only the start
312 of the string is highlighted." 316 of the string is highlighted."
313 ;; #### I18N3 should set standard-output to be (temporarily) 317 ;; #### I18N3 should set standard-output to be (temporarily)
314 ;; output-translating. 318 ;; output-translating.
315 (cl-parsing-keywords 319 (let ((old-buffer (current-buffer)) (bufferp (bufferp standard-output)))
316 ((:activate-callback 'default-choose-completion) 320 (if bufferp
317 :user-data 321 (set-buffer standard-output))
318 :reference-buffer 322 (if (null completions)
319 (:help-string completion-default-help-string) 323 (princ (gettext
320 (:completion-string "Possible completions are:") 324 "There are no possible completions of what you have typed."))
321 :window-width 325 (let ((win-width
322 :window-height) 326 (or window-width
323 () 327 (if bufferp
324 (let ((old-buffer (current-buffer)) 328 ;; We have to use last-nonminibuf-frame here
325 (bufferp (bufferp standard-output))) 329 ;; and not selected-frame because if a
326 (if bufferp 330 ;; minibuffer-only frame is being used it will
327 (set-buffer standard-output)) 331 ;; be the selected-frame at the point this is
328 (if (null completions) 332 ;; run. We keep the selected-frame call around
329 (princ (gettext 333 ;; just in case.
330 "There are no possible completions of what you have typed.")) 334 (window-width (get-lru-window (last-nonminibuf-frame)))
331 (let ((win-width 335 80))))
332 (or cl-window-width 336 (let ((count 0)
333 (if bufferp 337 (max-width 0)
334 ;; We have to use last-nonminibuf-frame here 338 old-max-width)
335 ;; and not selected-frame because if a 339 ;; Find longest completion
336 ;; minibuffer-only frame is being used it will 340 (let ((tail completions))
337 ;; be the selected-frame at the point this is 341 (while tail
338 ;; run. We keep the selected-frame call around 342 (let* ((elt (car tail))
339 ;; just in case. 343 (len (cond ((stringp elt)
340 (window-width (get-lru-window (last-nonminibuf-frame))) 344 (length elt))
341 80)))) 345 ((and (consp elt)
342 (let ((count 0) 346 (stringp (car elt))
343 (max-width 0) 347 (stringp (car (cdr elt))))
344 old-max-width) 348 (+ (length (car elt))
345 ;; Find longest completion 349 (length (car (cdr elt)))))
346 (let ((tail completions)) 350 (t
347 (while tail 351 (signal 'wrong-type-argument
348 (let* ((elt (car tail)) 352 (list 'stringp elt))))))
349 (len (cond ((stringp elt) 353 (if (> len max-width)
350 (length elt)) 354 (setq max-width len))
351 ((and (consp elt) 355 (setq count (1+ count)
352 (stringp (car elt)) 356 tail (cdr tail)))))
353 (stringp (car (cdr elt))))
354 (+ (length (car elt))
355 (length (car (cdr elt)))))
356 (t
357 (signal 'wrong-type-argument
358 (list 'stringp elt))))))
359 (if (> len max-width)
360 (setq max-width len))
361 (setq count (1+ count)
362 tail (cdr tail)))))
363 357
364 (setq max-width (+ 2 max-width)) ; at least two chars between cols 358 (setq max-width (+ 2 max-width)) ; at least two chars between cols
365 (setq old-max-width max-width) 359 (setq old-max-width max-width)
366 (let ((rows (let ((cols (min (/ win-width max-width) count))) 360 (let ((rows (let ((cols (min (/ win-width max-width) count)))
367 (if (<= cols 1) 361 (if (<= cols 1)
368 count 362 count
369 (progn 363 (progn
370 ;; re-space the columns 364 ;; re-space the columns
371 (setq max-width (/ win-width cols)) 365 (setq max-width (/ win-width cols))
372 (if (/= (% count cols) 0) ; want ceiling... 366 (if (/= (% count cols) 0) ; want ceiling...
373 (1+ (/ count cols)) 367 (1+ (/ count cols))
374 (/ count cols))))))) 368 (/ count cols)))))))
375 (when 369 (when
376 (and cl-window-height 370 (and window-height
377 (> rows cl-window-height)) 371 (> rows window-height))
378 (setq max-width old-max-width) 372 (setq max-width old-max-width)
379 (setq rows cl-window-height)) 373 (setq rows window-height))
380 (when (and (stringp cl-completion-string) 374 (when (and (stringp completion-string)
381 (> (length cl-completion-string) 0)) 375 (> (length completion-string) 0))
382 (princ (gettext cl-completion-string)) 376 (princ (gettext completion-string))
383 (terpri)) 377 (terpri))
384 (let ((tail completions) 378 (let ((tail completions)
385 (r 0) 379 (r 0)
386 (regexp-string 380 (regexp-string
387 (if (eq t 381 (if (eq t
388 completion-highlight-first-word-only) 382 completion-highlight-first-word-only)
389 "[ \t]" 383 "[ \t]"
390 completion-highlight-first-word-only))) 384 completion-highlight-first-word-only)))
391 (while (< r rows) 385 (while (< r rows)
392 (and (> r 0) (terpri)) 386 (and (> r 0) (terpri))
393 (let ((indent 0) 387 (let ((indent 0)
394 (column 0) 388 (column 0)
395 (tail2 tail)) 389 (tail2 tail))
396 (while tail2 390 (while tail2
397 (let ((elt (car tail2))) 391 (let ((elt (car tail2)))
398 (if (/= indent 0) 392 (if (/= indent 0)
399 (if bufferp 393 (if bufferp
400 (indent-to indent 2) 394 (indent-to indent 2)
401 (while (progn (write-char ?\ ) 395 (while (progn (write-char ?\ )
402 (setq column (1+ column)) 396 (setq column (1+ column))
403 (< column indent))))) 397 (< column indent)))))
404 (setq indent (+ indent max-width)) 398 (setq indent (+ indent max-width))
405 (let ((start (point)) 399 (let ((start (point))
406 end) 400 end)
407 ;; Frob some mousable extents in there too! 401 ;; Frob some mousable extents in there too!
408 (if (consp elt) 402 (if (consp elt)
409 (progn 403 (progn
410 (princ (car elt)) 404 (princ (car elt))
411 (princ (car (cdr elt))) 405 (princ (car (cdr elt)))
412 (or bufferp 406 (or bufferp
413 (setq column 407 (setq column
414 (+ column 408 (+ column
415 (length (car elt)) 409 (length (car elt))
416 (length (car (cdr elt))))))) 410 (length (car (cdr elt)))))))
417 (progn 411 (progn
418 (princ elt) 412 (princ elt)
419 (or bufferp 413 (or bufferp
420 (setq column (+ column (length 414 (setq column (+ column (length
421 elt)))))) 415 elt))))))
422 (add-list-mode-item 416 (add-list-mode-item
423 start 417 start
424 (progn 418 (progn
425 (setq end (point)) 419 (setq end (point))
426 (or 420 (or
427 (and completion-highlight-first-word-only 421 (and completion-highlight-first-word-only
428 (goto-char start) 422 (goto-char start)
429 (re-search-forward regexp-string end t) 423 (re-search-forward regexp-string end t)
430 (match-beginning 0)) 424 (match-beginning 0))
431 end)) 425 end))
432 nil cl-activate-callback cl-user-data) 426 nil activate-callback user-data)
433 (goto-char end))) 427 (goto-char end)))
434 (setq tail2 (nthcdr rows tail2))) 428 (setq tail2 (nthcdr rows tail2)))
435 (setq tail (cdr tail) 429 (setq tail (cdr tail)
436 r (1+ r))))))))) 430 r (1+ r)))))))))
437 (if bufferp 431 (if bufferp
438 (set-buffer old-buffer))) 432 (set-buffer old-buffer)))
439 (save-excursion 433 (save-excursion
440 (let ((mainbuf (or cl-reference-buffer (current-buffer)))) 434 (let ((mainbuf (or reference-buffer (current-buffer))))
441 (set-buffer standard-output) 435 (set-buffer standard-output)
442 (completion-list-mode) 436 (completion-list-mode)
443 (make-local-variable 'completion-reference-buffer) 437 (make-local-variable 'completion-reference-buffer)
444 (setq completion-reference-buffer mainbuf) 438 (setq completion-reference-buffer mainbuf)
445 ;;; The value 0 is right in most cases, but not for file name completion. 439 ;;; The value 0 is right in most cases, but not for file name completion.
446 ;;; so this has to be turned off. 440 ;;; so this has to be turned off.
447 ;;; (setq completion-base-size 0) 441 ;;; (setq completion-base-size 0)
448 (goto-char (point-min)) 442 (goto-char (point-min))
449 (let ((buffer-read-only nil)) 443 (let ((buffer-read-only nil))
450 (insert (eval cl-help-string))) 444 (insert (eval help-string)))
451 ;; unnecessary FSFmacs crock 445 ;; unnecessary FSFmacs crock
452 ;;(forward-line 1) 446 ;;(forward-line 1)
453 ;;(while (re-search-forward "[^ \t\n]+\\( [^ \t\n]+\\)*" nil t) 447 ;;(while (re-search-forward "[^ \t\n]+\\( [^ \t\n]+\\)*" nil t)
454 ;; (let ((beg (match-beginning 0)) 448 ;; (let ((beg (match-beginning 0))
455 ;; (end (point))) 449 ;; (end (point)))
456 ;; (if completion-fixup-function 450 ;; (if completion-fixup-function
457 ;; (funcall completion-fixup-function)) 451 ;; (funcall completion-fixup-function))
458 ;; (put-text-property beg (point) 'mouse-face 'highlight) 452 ;; (put-text-property beg (point) 'mouse-face 'highlight)
459 ;; (put-text-property beg (point) 'list-mode-item t) 453 ;; (put-text-property beg (point) 'list-mode-item t)
460 ;; (goto-char end))))) 454 ;; (goto-char end)))))
461 )) 455 ))
462 (save-excursion 456 (save-excursion
463 (set-buffer standard-output) 457 (set-buffer standard-output)
464 (run-hooks 'completion-setup-hook)))) 458 (run-hooks 'completion-setup-hook)))
465 459
466 (defvar completion-display-completion-list-function 'display-completion-list 460 (defvar completion-display-completion-list-function 'display-completion-list
467 "Function to set up the list of completions in the completion buffer. 461 "Function to set up the list of completions in the completion buffer.
468 The function is called with one argument, the sorted list of completions. 462 The function is called with one argument, the sorted list of completions.
469 Particular minibuffer interface functions (e.g. `read-file-name') may 463 Particular minibuffer interface functions (e.g. `read-file-name') may