home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / ilisp / ilisp-cmp.el < prev    next >
Encoding:
Text File  |  1995-02-21  |  11.6 KB  |  335 lines
  1. ;;; -*- Mode: Emacs-Lisp -*-
  2.  
  3. ;;; ilisp-cmp.el --
  4.  
  5. ;;; This file is part of ILISP.
  6. ;;; Version: 5.7
  7. ;;;
  8. ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell
  9. ;;;               1993, 1994 Ivan Vasquez
  10. ;;;               1994, 1995 Marco Antoniotti and Rick Busdiecker
  11. ;;;
  12. ;;; Other authors' names for which this Copyright notice also holds
  13. ;;; may appear later in this file.
  14. ;;;
  15. ;;; Send mail to 'ilisp-request@lehman.com' to be included in the
  16. ;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP
  17. ;;; mailing list were bugs and improvements are discussed.
  18. ;;;
  19. ;;; ILISP is freely redistributable under the terms found in the file
  20. ;;; COPYING.
  21.  
  22.  
  23.  
  24. ;;;
  25. ;;; ILISP completion
  26. ;;;
  27. ;;;
  28. ;;;%Completion
  29. ;;; The basic idea behind the completion stuff is to use as much of
  30. ;;; the standard Emacs stuff as possible.  The extensions here go out
  31. ;;; to the inferior LISP to complete symbols if necessary.  
  32. ;;; 
  33. (defun ilisp-display-choices (symbol choices)
  34.   "Display the possible choices for SYMBOL in alist CHOICES."
  35.   (with-output-to-temp-buffer "*Completions*"
  36.     (display-completion-list
  37.      (sort 
  38.       (all-completions (lisp-symbol-name symbol) choices)
  39.       'string-lessp))))
  40.  
  41. ;;;%%ilisp-can-complete
  42. (defun ilisp-can-complete (symbol function-p)
  43.   "Return T if ilisp completion can complete SYMBOL from the current table."
  44.   (and ilisp-original 
  45.        (string= (lisp-symbol-package ilisp-original) 
  46.         (lisp-symbol-package symbol))
  47.        (string= (lisp-symbol-delimiter ilisp-original)
  48.         (lisp-symbol-delimiter symbol))
  49.        (lisp-prefix-p (lisp-symbol-name ilisp-original)
  50.               (lisp-symbol-name symbol))
  51.        (eq function-p ilisp-original-function-p)))
  52.  
  53. ;;;%%ilisp-complete
  54. (defun ilisp-complete (symbol &optional function-p)
  55.   "Return a list of the possible completions for symbol from the
  56. inferior LISP.  If FUNCTION-P is T, only symbols with function
  57. bindings will be considered.  If no package is specified the buffer
  58. package will be used."
  59.   (let* ((choices 
  60.       (ilisp-send 
  61.        (format  (ilisp-value 'ilisp-complete-command) 
  62.             (lisp-symbol-name symbol) (lisp-symbol-package symbol)
  63.             function-p
  64.             (string= (lisp-symbol-delimiter symbol) ":")
  65.             ilisp-prefix-match)
  66.        (if (not ilisp-complete)
  67.            (concat "Complete " 
  68.                (if function-p "function ")
  69.                (lisp-buffer-symbol symbol)))
  70.        'complete)))
  71.     (if (ilisp-value 'comint-errorp t)
  72.     (progn (lisp-display-output choices)
  73.            (error "Error completing %s" (lisp-buffer-symbol symbol)))
  74.     (setq choices (read choices)
  75.           choices (if (eq choices 'NIL) nil choices)))
  76.     (setq ilisp-original symbol
  77.       ilisp-original-function-p function-p
  78.       ilisp-original-table choices)))
  79.  
  80. ;;;%%ilisp-completion-table
  81. (defun ilisp-completion-table (symbol function-p)
  82.   "Return the completion table for SYMBOL trying to use the current
  83. one.  If FUNCTION-P is T, only symbols with function cells will be
  84. returned."
  85.   (if (ilisp-can-complete symbol function-p) 
  86.       ilisp-original-table
  87.       (ilisp-complete symbol function-p)))
  88.  
  89. ;;;%%Minibuffer completion
  90. (defun ilisp-restore-prefix ()
  91.   "Restore the prefix from ilisp-mini-prefix at the start of the
  92. minibuffer."
  93.   (if ilisp-mini-prefix
  94.       (save-excursion
  95.     (goto-char (point-min))
  96.     (insert ilisp-mini-prefix)
  97.     (setq ilisp-mini-prefix nil))))
  98.  
  99. ;;;
  100. (defun ilisp-current-choice ()
  101.   "Set up the minibuffer completion table for the current symbol.
  102. If there is a paren at the start of the minibuffer, or there is not an
  103. ilisp-table, this will be from the inferior LISP.  Otherwise, it will
  104. be the ilisp-table."
  105.   (if (or (null ilisp-table) (eq (char-after 1) ?\())
  106.       (progn
  107.     (let* ((symbol-info (lisp-previous-symbol))
  108.            (symbol (car symbol-info)))
  109.       (setq minibuffer-completion-table 
  110.         (ilisp-completion-table symbol ilisp-completion-function-p)))
  111.     (save-excursion 
  112.       (skip-chars-backward "^: \(")
  113.       (setq ilisp-mini-prefix (buffer-substring (point-min) (point)))
  114.       (delete-region (point-min) (point)))
  115.     ;; Nothing can match this table
  116.     (if (not minibuffer-completion-table)
  117.         (setq minibuffer-completion-table '((" ")))))
  118.       (setq minibuffer-completion-table ilisp-table
  119.         minibuffer-completion-predicate nil)))
  120.  
  121. ;;;%%Commands
  122. (defvar ilisp-completion-help
  123.   (lookup-key minibuffer-local-must-match-map "?"))
  124. (defun ilisp-completion-help ()
  125.   "Inferior LISP minibuffer completion help."
  126.   (interactive)
  127.   (ilisp-current-choice) 
  128.   (funcall ilisp-completion-help)
  129.   (ilisp-restore-prefix))
  130.  
  131. ;;;
  132. (defvar ilisp-completion
  133.   (lookup-key minibuffer-local-must-match-map "\t"))
  134. (defun ilisp-completion ()
  135.   "Inferior LISP minibuffer complete."
  136.   (interactive)
  137.   (ilisp-current-choice)
  138.   (funcall ilisp-completion)
  139.   (ilisp-restore-prefix))
  140.  
  141. ;;;
  142. (defvar ilisp-completion-word
  143.   (lookup-key minibuffer-local-must-match-map " "))
  144. (defun ilisp-completion-word ()
  145.   "Inferior LISP minibuffer complete word."
  146.   (interactive)
  147.   (if (eq (char-after 1) ?\()
  148.       (insert " ")
  149.       (ilisp-current-choice)
  150.       (funcall ilisp-completion-word)
  151.       (ilisp-restore-prefix)))
  152.  
  153. ;;;
  154. (defun ilisp-completion-paren ()
  155.   "Only allow a paren if ilisp-paren is T."
  156.   (interactive)
  157.   (if ilisp-paren 
  158.       (if (or (eq last-input-char ?\() (eq (char-after 1) ?\())
  159.       (insert last-input-char)
  160.       (beep))
  161.       (beep)))
  162.       
  163. ;;; 
  164. (defvar ilisp-completion-exit 
  165.   (lookup-key minibuffer-local-must-match-map "\n"))
  166. (defun ilisp-completion-exit ()
  167.   "Inferior LISP completion complete and exit."
  168.   (interactive)
  169.   (if (eq (char-after 1) ?\()
  170.       (progn (find-unbalanced-lisp nil)
  171.          (exit-minibuffer))
  172.       (if ilisp-no-complete
  173.       (exit-minibuffer)
  174.       (if (= (point-min) (point-max))
  175.           (exit-minibuffer)
  176.           (ilisp-current-choice)
  177.           (unwind-protect (funcall ilisp-completion-exit)
  178.         (ilisp-restore-prefix))))))
  179.  
  180. ;;;%%ilisp-completer
  181. (defun ilisp-completer (symbol function-p)
  182.   "Complete SYMBOL from the inferior LISP using only function symbols
  183. if FUNCTION-P is T.  Return (SYMBOL LCS-SYMBOL CHOICES UNIQUEP)."
  184.   (let* ((name (lisp-symbol-name symbol))
  185.      (table (ilisp-completion-table symbol function-p))
  186.      (choice (and table (try-completion name table))))
  187.     (cond ((eq choice t)        ;Name is it
  188.        (list symbol symbol nil t))
  189.       ((string= name choice)    ;Name is LCS
  190.        (list symbol symbol (all-completions name table) nil))
  191.       (choice            ;New LCS
  192.        (let ((symbol
  193.           (lisp-symbol (lisp-symbol-package symbol) 
  194.                    (lisp-symbol-delimiter symbol)
  195.                    choice)))
  196.          (list symbol symbol (all-completions choice table) nil)))
  197.       ((and (not ilisp-prefix-match) table)    ;Try partial matches
  198.        (let ((matches
  199.           (completer name table nil (regexp-quote completer-words))))
  200.          (cons (lisp-symbol (lisp-symbol-package symbol)
  201.                 (lisp-symbol-delimiter symbol)
  202.                 (car matches))
  203.            (cons  (lisp-symbol (lisp-symbol-package symbol)
  204.                 (lisp-symbol-delimiter symbol)
  205.                 (car (cdr matches)))
  206.               (cdr (cdr matches)))))))))
  207.  
  208.  
  209. ;;;%%ilisp-read
  210. (defun ilisp-completion-map ()
  211.   "Set up the ilisp-completion-map from lisp-mode-map for the ilisp
  212. readers and return it."
  213.   (if (not ilisp-completion-map)
  214.       (progn
  215.     (if (fboundp 'set-keymap-parent)
  216.         (progn
  217.           (setq ilisp-completion-map (make-sparse-keymap))
  218.           (set-keymap-parent ilisp-completion-map lisp-mode-map))
  219.       (setq ilisp-completion-map (copy-keymap lisp-mode-map)))
  220.     (define-key ilisp-completion-map " "  'ilisp-completion-word)
  221.     (define-key ilisp-completion-map "\t" 'ilisp-completion)
  222.     (define-key ilisp-completion-map "?" 'ilisp-completion-help)
  223.     (define-key ilisp-completion-map "\M-\t" 'ilisp-completion)
  224.     (define-key ilisp-completion-map "\n" 'ilisp-completion-exit)
  225.     (define-key ilisp-completion-map "\r" 'ilisp-completion-exit)
  226.     (define-key ilisp-completion-map "\C-g" 'abort-recursive-edit)
  227.     (define-key ilisp-completion-map "(" 'ilisp-completion-paren)
  228.     (define-key ilisp-completion-map ")" 'ilisp-completion-paren)
  229.     (define-key ilisp-completion-map "'" nil)
  230.     (define-key ilisp-completion-map "#" nil)
  231.     (define-key ilisp-completion-map "\"" nil)))
  232.   ilisp-completion-map)
  233.  
  234. ;;;
  235. (defun ilisp-read (prompt &optional initial-contents)
  236.   "PROMPT in the minibuffer with optional INITIAL-CONTENTS and return
  237. the result.  Completion of symbols though the inferior LISP is
  238. allowed."
  239.   (let ((ilisp-complete t)
  240.     (ilisp-paren t)
  241.     (ilisp-no-complete t)
  242.     (ilisp-completion-package (lisp-buffer-package)))
  243.     (read-from-minibuffer prompt initial-contents
  244.               (ilisp-completion-map))))
  245.  
  246. ;;;%%lisp-read-program
  247. (defvar lisp-program-map nil
  248.   "Minibuffer map for reading a program and arguments.")
  249.  
  250. ;;;
  251. (defun lisp-read-program (prompt &optional initial)
  252.   "Read a program with PROMPT and INITIAL.  TAB or Esc-TAB will complete
  253. filenames."
  254.   (if (null lisp-program-map)
  255.       (progn 
  256.     (if (fboundp 'set-keymap-parent)
  257.         (progn
  258.           (setq lisp-program-map (make-sparse-keymap))
  259.           (set-keymap-parent lisp-program-map minibuffer-local-map))
  260.       (setq lisp-program-map (copy-keymap minibuffer-local-map)))
  261.     (define-key lisp-program-map "\M-\t" 'comint-dynamic-complete)
  262.     (define-key lisp-program-map "\t" 'comint-dynamic-complete)
  263.     (define-key lisp-program-map "?" 'comint-dynamic-list-completions)))
  264.   (read-from-minibuffer prompt initial lisp-program-map))
  265.  
  266. ;;;%%ilisp-read-symbol
  267. (defun ilisp-read-symbol (prompt &optional default function-p no-complete)
  268.   "PROMPT in the minibuffer with optional DEFAULT and return a symbol
  269. from the inferior LISP.  If FUNCTION-P is T, only symbols with
  270. function values will be returned.  If NO-COMPLETE is T, then
  271. uncompleted symbols will be allowed."
  272.   (let* ((ilisp-complete t)
  273.      (ilisp-no-complete no-complete)
  274.      (ilisp-completion-package (lisp-buffer-package))
  275.      (ilisp-completion-function-p function-p)
  276.      (string (read-from-minibuffer prompt nil (ilisp-completion-map))))
  277.     (if (equal string "")
  278.     default
  279.     (lisp-string-to-symbol string))))
  280.  
  281. ;;;%%ilisp-completing-read
  282. (defun ilisp-completing-read (prompt table &optional default)
  283.   "Read with PROMPT from an alist of TABLE.  No input returns DEFAULT.
  284. Symbols are from table, other specs are in parentheses."
  285.   (let* ((ilisp-complete t)
  286.      (ilisp-table table)
  287.      (ilisp-completion-package (lisp-buffer-package))
  288.      (ilisp-paren
  289.       (let ((entry table) (done nil))
  290.         (while (and entry (not done))
  291.           (setq done (= (elt (car (car entry)) 0) ?\()
  292.             entry (cdr entry)))
  293.         done))
  294.      (string (read-from-minibuffer prompt nil (ilisp-completion-map))))
  295.     (if (string= string "") default string)))
  296.  
  297.  
  298.  
  299. ;;;%%complete-lisp
  300. (autoload 'complete "completion" "Complete previous symbol." t)
  301. (defun complete-lisp (mode)
  302.   "Complete the current symbol using information from the current
  303. ILISP buffer.  If in a string, complete as a filename.  If called with
  304. a positive prefix force all symbols to be considered.  If called with
  305. a negative prefix, undo the last completion.  Partial completion is
  306. allowed unless ilisp-prefix-match is T.  If a symbol starts after a
  307. left paren or #', then only function symbols will be considered.
  308. Package specifications are also allowed and the distinction between
  309. internal and exported symbols is considered."
  310.   (interactive "P")
  311.   (if (< (prefix-numeric-value mode) 0)
  312.       (completer-undo)
  313.       (let* ((filep
  314.           (save-excursion
  315.         (skip-chars-backward "^ \t\n")
  316.         (= (char-after (point)) ?\"))))
  317.     (if filep
  318.         (comint-dynamic-complete)
  319.         (let* ((symbol-info (lisp-previous-symbol))
  320.            (symbol (car symbol-info))
  321.            (name (lisp-symbol-name symbol))
  322.            (choice (ilisp-completer 
  323.                 symbol 
  324.                 (if (not mode) (car (cdr symbol-info)))))
  325.            (match (lisp-buffer-symbol (car choice)))
  326.            (lcs (lisp-buffer-symbol (car (cdr choice))))
  327.            (choices (car (cdr (cdr choice))))
  328.            (unique (car (cdr (cdr (cdr choice))))))
  329.           (skip-chars-backward " \t\n")
  330.           (completer-goto match lcs choices unique 
  331.                   (ilisp-value 'ilisp-symbol-delimiters)
  332.                   completer-words)))
  333.     (message "Completed"))))
  334.  
  335.