1 ;;; ***********************************************************
  2 ;;; *                                                         *
  3 ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4 ;;; *                                                         *
  5 ;;; * Copyright (c) 1981 by Massachusetts Institute of        *
  6 ;;; * Technology and Honeywell Information Systems, Inc.      *
  7 ;;; *                                                         *
  8 ;;; ***********************************************************
  9 ;;;
 10 ;;; Emacs completion command and underpinnings.
 11 ;;;
 12 ;;; Richard Mark Soley and Barry Margolin, August 1981
 13 ;;; Modified 19 November 1981 RMSoley for trying other completions on
 14 ;;;       successive ESC-SPACE's, disallow minibuffer, get rid of table.
 15 ;;; Modified 3 October 1982 B. Margolin for not depending upon being
 16 ;;;       bound to ESC-SPACE.
 17 ;;; Modified 19 January 1984 B. Margolin to comment out register-option form,
 18 ;;;          as it was moved to e_option_defaults_.
 19 ;;;
 20 
 21 (declare (special completion-list cmp:worked cmp:mark cmp:last-completion
 22                   cmp:allow-ambiguous X Y minibufferp
 23                   previous-command current-command)
 24          (*lexpr cmp:get-completion)
 25          (*expr DCTL-position-cursor))
 26 
 27 (%include e-macros)
 28 
 29 (eval-when (eval compile)
 30 (defun abort-completion macro (form)
 31        '(prog2 (ring-tty-bell) (throw 0 nocomplete)))
 32 (defun catch-abort macro (form)
 33        `(catch ,@(cdr form) nocomplete)))
 34 
 35 (or (boundp 'completion-list) (setq completion-list nil))
 36 (setq cmp:worked nil cmp:mark nil cmp:last-completion nil)
 37 ;;; (register-option 'cmp:allow-ambiguous 'On) ;moved to e_option_defaults_
 38 
 39 (defcom complete-command
 40         &numeric-argument (&pass)
 41         (cond ((not minibufferp) (command-quit))
 42               (numarg
 43                 (or (eq previous-command current-command)
 44                     (setq cmp:worked nil))
 45                 (cmp:display-completions))
 46               ((cmp:undo-completion?)
 47                (without-saving (wipe-point-mark cmp:mark))
 48                (release-mark cmp:mark)
 49                (catch-abort
 50                  (let ((completion-info
 51                          (cmp:get-completion (cmp:get-word)
 52                                              cmp:last-completion)))
 53                       (cond (completion-info
 54                               (setq cmp:worked t
 55                                     cmp:last-completion (car completion-info))
 56                               (insert-string
 57                                 (substr (car completion-info)
 58                                         (cdr completion-info)))
 59                               (insert-string SPACE))
 60                             (t (setq cmp:worked nil cmp:mark nil))))))
 61               (t (catch-abort
 62                    (let ((completion-info (cmp:get-completion (cmp:get-word))))
 63                         (cond (completion-info
 64                                 (setq cmp:worked t
 65                                       cmp:last-completion (car completion-info))
 66                                 (insert-string
 67                                   (substr (car completion-info)
 68                                           (cdr completion-info)))
 69                                 (insert-char SPACE))))))))
 70 
 71 (defun cmp:undo-completion? ()
 72        (and cmp:worked
 73             cmp:mark
 74             (eq previous-command 'complete-command)))
 75 
 76 (defun cmp:set-mark ()
 77        (and cmp:mark (release-mark cmp:mark))
 78        (setq cmp:mark (set-mark)))
 79 
 80 (defun cmp:get-word ()
 81        (cmp:set-mark)
 82        (with-mark
 83          here
 84          (go-to-beginning-of-line)
 85          (prog1 (point-mark-to-string here)
 86                 (go-to-mark here))))
 87 
 88 (defun cmp:get-completion lexpr
 89        (let ((word (arg 1))
 90              (ignore-until (and (> lexpr 1) (arg 2)))
 91              (found nil))
 92             (do ((words (cond (ignore-until
 93                                 (cdr (member ignore-until completion-list)))
 94                               (t completion-list))
 95                         (cdr words)))
 96                 ((null words)
 97                  (cond (found found)
 98                        (t (setq cmp:last-completion nil)
 99                           (abort-completion))))
100                 (let ((cur-word (car words)))
101                      (and (= (index cur-word word) 1)
102                           (cond
103                             (cmp:allow-ambiguous
104                               (return (cons cur-word
105                                             (1+ (stringlength word)))))
106                             (found (abort-completion))
107                             (t (setq found
108                                      (cons cur-word
109                                            (1+ (stringlength word)))))))))))
110 
111 (defun cmp:display-completions ()
112        (or completion-list
113            (display-error "There are no completions in effect."))
114        (let ((littleX X) (littleY Y))
115             (init-local-displays)
116             (local-display-generator-nnl "Current Completions in Effect")
117             (local-display-generator-nnl "")
118             (do ((words completion-list (cdr words)))
119                 ((null words))
120                 (local-display-generator-nnl (car words)))
121             (end-local-displays)
122             (DCTL-position-cursor littleX littleY)))