home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / kcl_tar.z / kcl_tar / lsp / packlib.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1987-06-04  |  5.2 KB  |  170 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;;    packlib.lsp
  6. ;;;;
  7. ;;;;                    package routines
  8.  
  9.  
  10. (in-package 'lisp)
  11.  
  12.  
  13. (export '(find-all-symbols do-symbols do-external-symbols do-all-symbols))
  14. (export '(apropos apropos-list))
  15.  
  16.  
  17. (in-package 'system)
  18.  
  19.  
  20. (proclaim '(optimize (safety 2) (space 3)))
  21.  
  22.  
  23. (defmacro coerce-to-package (p)
  24.   (if (eq p '*package*)
  25.       p
  26.       (let ((g (gensym)))
  27.         `(let ((,g ,p))
  28.            (if (packagep ,g)
  29.                ,g
  30.                (find-package (string ,g)))))))
  31.  
  32. (defun find-all-symbols (string-or-symbol)
  33.   (when (symbolp string-or-symbol)
  34.         (setq string-or-symbol (symbol-name string-or-symbol)))
  35.   (mapcan #'(lambda (p)
  36.               (multiple-value-bind (s i)
  37.                   (find-symbol string-or-symbol p)
  38.                 (if (or (eq i :internal) (eq i :external))
  39.                     (list s)
  40.                     nil)))
  41.           (list-all-packages)))
  42.  
  43.  
  44. (defmacro do-symbols ((var &optional (package '*package*) (result-form nil))
  45.                       . body)
  46.   (let ((p (gensym)) (i (gensym)) (l (gensym))
  47.         (loop (gensym)) (break (gensym)) declaration)
  48.     (multiple-value-setq (declaration body) (find-declarations body))
  49.     `(let ((,p (coerce-to-package ,package)) ,var ,l)
  50.        ,@declaration
  51.        (dotimes (,i 1024 (progn (setq ,var nil) ,result-form))
  52.          (setq ,l (if (< ,i 512)
  53.                       (si:package-internal ,p ,i)
  54.                       (si:package-external ,p (- ,i 512))))
  55.        ,loop
  56.          (when (null ,l) (go ,break))
  57.          (setq ,var (car ,l))
  58.          ,@body
  59.          (setq ,l (cdr ,l))
  60.          (go ,loop)
  61.        ,break))))
  62.        
  63.  
  64. (defmacro do-external-symbols
  65.           ((var &optional (package '*package*) (result-form nil)) . body)
  66.   (let ((p (gensym)) (i (gensym)) (l (gensym))
  67.         (loop (gensym)) (break (gensym)) declaration)
  68.     (multiple-value-setq (declaration body)
  69.                          (find-declarations body))
  70.     `(let ((,p (coerce-to-package ,package)) ,var ,l)
  71.        ,@declaration
  72.        (dotimes (,i 512 (progn (setq ,var nil) ,result-form))
  73.          (setq ,l (si:package-external ,p ,i))
  74.        ,loop
  75.          (when (null ,l) (go ,break))
  76.          (setq ,var (car ,l))
  77.          ,@body
  78.          (setq ,l (cdr ,l))
  79.          (go ,loop)
  80.        ,break))))
  81.  
  82.  
  83. (defmacro do-all-symbols ((var &optional (result-form nil)) . body)
  84.   (let ((pl (gensym)) (i (gensym)) (l (gensym))
  85.         (loop-i (gensym)) (break-i (gensym))
  86.         (loop (gensym)) (break (gensym))
  87.         declaration)
  88.     (multiple-value-setq (declaration body) (find-declarations body))
  89.     `(do ((,pl (list-all-packages) (cdr ,pl)) (,var) (,i 0 0) (,l))
  90.          ((null ,pl) (setq ,var nil) ,result-form)
  91.        ,@declaration
  92.      ,loop-i
  93.        (when (>= ,i 1024) (go ,break-i))
  94.        (setq ,l (if (< ,i 512)
  95.                     (si:package-internal (car ,pl) ,i)
  96.                     (si:package-external (car ,pl) (- ,i 512))))
  97.      ,loop
  98.        (when (null ,l) (go ,break))
  99.        (setq ,var (car ,l))
  100.        ,@body
  101.        (setq ,l (cdr ,l))
  102.        (go ,loop)
  103.      ,break
  104.        (setq ,i (1+ ,i))
  105.        (go ,loop-i)
  106.      ,break-i)))
  107.  
  108.  
  109. (defun substringp (sub str)
  110.   (do ((i (- (length str) (length sub)))
  111.        (l (length sub))
  112.        (j 0 (1+ j)))
  113.       ((> j i) nil)
  114.     (when (string-equal sub str :start2 j :end2 (+ j l))
  115.           (return t))))
  116.  
  117.  
  118. (defun print-symbol-apropos (symbol)
  119.   (prin1 symbol)
  120.   (when (fboundp symbol)
  121.         (if (special-form-p symbol)
  122.             (princ "  Special form")
  123.             (if (macro-function symbol)
  124.                 (princ "  Macro")
  125.                 (princ "  Function"))))
  126.   (when (boundp symbol)
  127.         (if (constantp symbol)
  128.             (princ "  Constant: ")
  129.             (princ "  has value: "))
  130.         (prin1 (symbol-value symbol)))
  131.   (terpri))
  132.  
  133.  
  134. (defun apropos (string &optional package)
  135.   (setq string (string string))
  136.   (cond (package
  137.          (do-symbols (symbol package)
  138.            (when (substringp string (string symbol))
  139.                  (print-symbol-apropos symbol)))
  140.          (do ((p (package-use-list package) (cdr p)))
  141.              ((null p))
  142.            (do-external-symbols (symbol (car p))
  143.              (when (substringp string (string symbol))
  144.                    (print-symbol-apropos symbol)))))
  145.         (t
  146.          (do-all-symbols (symbol)
  147.            (when (substringp string (string symbol))
  148.                  (print-symbol-apropos symbol)))))
  149.   (values))
  150.  
  151.  
  152. (defun apropos-list (string &optional package &aux list)
  153.   (setq list nil)
  154.   (setq string (string string))
  155.   (cond (package
  156.          (do-symbols (symbol package)
  157.            (when (substringp string (string symbol))
  158.                  (setq list (cons symbol list))))
  159.          (do ((p (package-use-list package) (cdr p)))
  160.              ((null p))
  161.            (do-symbols (symbol (car p))
  162.              (when (substringp string (string symbol))
  163.                    (setq list (cons symbol list))))))
  164.         (t
  165.          (do-all-symbols (symbol)
  166.            (when (substringp string (string symbol))
  167.                  (setq list (cons symbol list))))))
  168.   list)
  169.  
  170.