Return to emacs.cl CVS log

Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / dist-1.3 / fi

Annotation of 43BSDReno/contrib/emacs-18.55/dist-1.3/fi/emacs.cl, revision 1.1.1.1

1.1       root        1: ;;                                     -[Thu Nov 17 09:51:33 1988 by layer]-
                      2: ;;
                      3: ;; The Allegro CL part of the Emacs/Lisp interface
                      4: ;;
                      5: ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. 
                      6: ;; copyright (c) 1986, 1987, 1988 Franz Inc, Berkeley, Ca.
                      7: ;;
                      8: ;; The software, data and information contained herein are proprietary
                      9: ;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
                     10: ;; given in confidence by Franz, Inc. pursuant to a written license
                     11: ;; agreement, and stored only in accordance with the terms of such license.
                     12: ;;
                     13: ;; Restricted Rights Legend
                     14: ;; ------------------------
                     15: ;; Use, duplication, and disclosure by the Government are subject to
                     16: ;; restrictions of Restricted Rights for Commercial Software developed
                     17: ;; at private expense as specified in DOD FAR 52.227-7013 (c) (1) (ii).
                     18: ;;
                     19: ;; $Header: emacs.cl,v 1.1 88/11/17 12:15:21 layer Exp $
                     20: 
                     21: (provide :emacs)
                     22: 
                     23: (in-package :excl)
                     24: 
                     25: (eval-when (compile)
                     26: 
                     27: (defmacro do-package-symbols ((var &optional (package '*package*) result-form)
                     28:                              &rest forms
                     29:                              &environment env)
                     30:   (let ((pkg (gensym))
                     31:        (p (gensym))
                     32:        (body (third (parse-body forms env))))
                     33:     `(let ((,pkg ,package))
                     34:       (if (not (packagep ,pkg)) (error "non-package to do-symbols: ~s" ,pkg))
                     35:       (prog nil
                     36:         (maphash #'(lambda (xx ,var)
                     37:                      (declare (ignore xx) (ignore-if-unused ,var))
                     38:                      ,@body)
                     39:                  (fast (package-internal-symbols ,pkg)))
                     40:         (maphash #'(lambda (xx ,var)
                     41:                      (declare (ignore xx) (ignore-if-unused ,var))
                     42:                      ,@body)
                     43:                  (fast (package-external-symbols ,pkg)))
                     44:         (return ,result-form)))))
                     45: )
                     46: 
                     47: (defun list-all-completions (string &optional package functions-only)
                     48:   "Return a list of all the accessible symbols with a print name starting
                     49: with the substring STRING. If PACKAGE is given, then the reference package
                     50: is PACKAGE."
                     51:   (declare (optimize (speed 3)))
                     52:   (let* ((substring (simple-string string))
                     53:         (substring-length (fast (length substring)))
                     54:         (substring-fixnums (apropos-fixnums substring substring-length))
                     55:         result pkg packages)
                     56:     (declare (simple-string substring))
                     57:     (if* package
                     58:        then (setq pkg (or (and (packagep package) package)
                     59:                          (fasl-find-package package)))
                     60:            (setq packages nil)
                     61:        else (setq pkg *package*)
                     62:            (setq packages (package-use-list pkg)))
                     63:     (dolist (p packages)
                     64:       (do-external-symbols (symbol p)
                     65:        (if (and (or (null functions-only)
                     66:                     (fboundp symbol))
                     67:                 (list-all-completions-search symbol substring-fixnums
                     68:                                              substring-length))
                     69:            (push symbol result))))
                     70:     (do-package-symbols (symbol pkg)
                     71:       (if (and (or (null functions-only)
                     72:                   (fboundp symbol))
                     73:               (list-all-completions-search symbol substring-fixnums
                     74:                                            substring-length))
                     75:          (push symbol result)))
                     76:     (delete-duplicates result :test #'eq)))
                     77: 
                     78: (defun list-all-completions-search (symbol fixnums flength)
                     79:   (declare (optimize (speed 3) (safety 0))
                     80:           (list fixnums)
                     81:           (fixnum flength))
                     82:   (let* ((name (symbol-name symbol))
                     83:         (symbol-length (the fixnum (length name))))
                     84:     (declare (type fixnum symbol-length))
                     85:     (if (< symbol-length flength)
                     86:        (return-from list-all-completions-search nil))
                     87:     (do* ((index 0 (the fixnum (1+ index)))
                     88:          (fixnums fixnums (cdr fixnums)))
                     89:         ((= index flength) t)
                     90:       (declare (type simple-string name)
                     91:               (type fixnum index))
                     92:       (unless (= (the fixnum (char-code (schar name index)))
                     93:                 (the fixnum (car fixnums)))
                     94:        (return nil)))))

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.