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     ! 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.