function and variable name completetion.

[Michael Pazzani <pazzani@ICS.UCI.EDU>]

Here's an extension to FRED that allows one to type
"escape" to complete the current function or variable
name, if possible.  If it finds a unique completion,
it completes it and inserts a space afterwards.  If there
is no completion, it beeps, and if there are several completiion,
it completes as much as possible.

control-? is similar, except if there is not a unique
completion, it pops up a menu of possible completions.

Completion also works from the lisp listener.

It redefines defun, defmacro, defvar, defconstant, and defparameter to
record the names being defined.  Any definitions performed after
loading this file will are stored and available for completion.

PROBLEMS: 
Redefining these causes a continuable warning, so one must
continue 5 times when loading this file.  Anyone know a way around
this problem?  Is there a better way to do this (and write FRED
commands in general)?  Why doesn't Apple provide the source code
like Symbolics?

It assumes you like your code typed in in lower case (i.e., it
downcases all symbols, and completes in lower case.)


Totally Unrelated Question:  Has anyone got Macintalk working
from MACL?

________________________________________________________________

(defvar *all-defs* nil)

(setf (get 'old-defun 'ccl::macrop)
      (get 'defun 'ccl::macrop))

(setf (get 'old-defvar 'ccl::macrop)
      (get 'defvar 'ccl::macrop))
(setf (get 'old-defparameter 'ccl::macrop)
      (get 'defparameter 'ccl::macrop))
(setf (get 'old-defconstant 'ccl::macrop)
      (get 'defconstant 'ccl::macrop))

(setf (get 'old-defmacro 'ccl::macrop)
      (get 'defmacro 'ccl::macrop))


(defmacro defun (name &rest rest)
  `(progn (pushnew (string-downcase (format nil "~a" ',name)) *all-defs*
                   :test #'string-equal)
          (old-defun ,name . ,rest)))

(defmacro defvar (name &rest rest)
  `(progn (pushnew (string-downcase (format nil "~a" ',name)) *all-defs*
                   :test #'string-equal)
          (old-defvar ,name . ,rest)))

(defmacro defconstant (name &rest rest)
  `(progn (pushnew (string-downcase (format nil "~a" ',name)) *all-defs*
                   :test #'string-equal)
          (old-defconstant ,name . ,rest)))
(defmacro defparameter (name &rest rest)
  `(progn (pushnew (string-downcase (format nil "~a" ',name)) *all-defs*
                   :test #'string-equal)
          (old-defparameter ,name . ,rest)))
(defmacro defmacro (name &rest rest)
  `(progn (pushnew (string-downcase (format nil "~a" ',name)) *all-defs*
                   :test #'string-equal)
          (old-defmacro ,name . ,rest)))

(defun complete-string (string strings 
                               &optional (menu nil)
                               &aux  c) 
  (setq string (string-downcase string))
  (let* ((l (length string))
         (j l)
         (matches (if (> l 0)
                    (remove-if #'(lambda(s)
                                   (or (> l(length s))
                                       (mismatch string s :end1 l 
                                                 :end2 l :start1 0 
                                                 :start2 0)))
                               strings)
                    strings)))
    (cond(matches
      (cond ((cdr matches) 
             (cond (menu (let ((v (select-item-from-list matches 
                                                         :window-title "Select a Completion")))
                           (if (consp v)
                             (values (subseq (car v) l) t)
                             (values nil nil))))
                   
                   (t 
                    (block find-j
                      (loop
                        (cond ((>= j (length (car matches)))
                               (return-from find-j))
                              (t (setq c (char (car matches) j))
                                 (dolist (s  (cdr matches))
                                   (if (or (>= j (length s))
                                           (not (eq c (char s j))))
                                     (return-from find-j)))))
                        (incf j)))
                    
                    (cond((= j l)
                          (values nil nil))
                         (t (values  (subseq (car matches) l j) nil))))))
            ((equal string (car matches))
             (values nil t))
            (t (values (subseq (car matches) l) t))))
         (t (ed-beep)
            (values nil nil)))))

(defobfun (ed-complete *fred-window*) ()
  (let (start-pos end-pos current-pos string)
    (setq current-pos (mark-position (window-cursor-mark)))
    (setq start-pos (mark-position (ccl::ed-backward-sexp)))
    (setq end-pos (mark-position (ccl::ed-forward-sexp)))
    (setq string (string-downcase (buffer-substring (window-cursor-mark) 
                                                     :start start-pos :end end-pos)))
    (multiple-value-bind (completion done)
                         (complete-string string *all-defs*)
      (when completion
        (dotimes (i (length completion))
          (ed-insert-char (char completion i)))
        (when done
          (ed-insert-char " "))))))

(defobfun (ed-complete-menu *fred-window*) ()
  (let (start-pos end-pos current-pos string)
    (setq current-pos (mark-position (window-cursor-mark)))
    (setq start-pos (mark-position (ccl::ed-backward-sexp)))
    (setq end-pos (mark-position (ccl::ed-forward-sexp)))
    (setq string (string-downcase (buffer-substring (window-cursor-mark) 
                                                     :start start-pos :end end-pos)))
    (multiple-value-bind (completion done)
                         (complete-string string *all-defs* t)
      (when completion
        (dotimes (i (length completion))
          (ed-insert-char (char completion i)))
        (when done
          (ed-insert-char " "))))))

(comtab-set-key *comtab* '(#\escape) 'ed-complete)
(comtab-set-key *comtab* '(:control #\?) 'ed-complete-menu)