source: trunk/ccl/lib/apropos.lisp @ 2325

Last change on this file since 2325 was 2325, checked in by bryan, 14 years ago

add (in-package "CCL") forms.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.8 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;; Apropos.lisp
18
19(in-package "CCL")
20
21(eval-when (:execute :compile-toplevel)
22   (require :level-2)
23   )
24
25(defun apropos-list (string &optional package &aux list)
26  "Like APROPOS, except that it returns a list of the symbols found instead
27  of describing them."
28  (setq string (string-arg string))
29  (if package
30    (do-symbols (sym package)
31      (when (%apropos-substring-p string (symbol-name sym))
32        (push sym list)))
33    (do-all-symbols (sym)
34      (when (%apropos-substring-p string (symbol-name sym))
35        (push sym list))))
36  (let* ((last 0)                      ; not a symbol
37         (junk #'(lambda (item)
38                   (declare (debugging-function-name nil))
39                   (or (eq item last) (progn (setq last item) nil)))))
40    (declare (dynamic-extent junk))
41    (setq list (delete-if junk (sort list #'string-lessp))))
42  list)
43
44(defvar *apropos-indent-to-search-string* nil)
45(defun apropos-list-aux (theString package indent-to-search-string &aux theList)
46    (setq theString (string-arg theString))
47    (if package
48      (do-symbols (sym package)
49        (when (%apropos-substring-p theString (symbol-name sym))
50          (push sym theList)))
51      (do-all-symbols (sym)
52        (when (%apropos-substring-p theString (symbol-name sym))
53          (push sym theList))))
54    (let* ((last 0)                      ; not a symbol
55           (junk #'(lambda (item)
56                     (declare (debugging-function-name nil))
57                     (or (eq item last) (progn (setq last item) nil)))))
58      (declare (dynamic-extent junk))
59      (sort-symbol-list (delete-if junk theList) (if indent-to-search-string
60                                                   theString
61                                                   nil))))
62 
63(defun apropos-string-indented (symTuple indent)
64    (let ((pr-string     (prin1-to-string (aref symTuple 0)))
65          (displayOffset (aref symTuple 3)))
66      (format nil "~v@a~a"
67              indent
68              (subseq pr-string 0 displayOffset)
69              (subseq pr-string displayOffset))))
70 
71
72(defun apropos-aux (theString symtuple indent)
73  (declare (ignore theString))
74  (let ((sym (aref symtuple 0))
75        val)
76    (format t "~a" (apropos-string-indented symtuple indent))
77    (when (setq val (fboundp sym))
78      (cond ((functionp val)
79             (princ ", Def: ")
80             (prin1 (type-of val)))
81            ((setq val (macro-function sym))
82             (princ ", Def: MACRO ")
83             (prin1 (type-of val)))
84            (t (princ ", Special form"))))
85    (when (boundp sym)
86      (princ ",  Value: ")
87      (prin1 (symbol-value sym)))
88    (terpri)))
89
90 
91(defun apropos (theString &optional package)
92    (multiple-value-bind (symVector indent) (apropos-list-aux theString package *apropos-indent-to-search-string*)
93      (loop for symtuple across symVector
94        do (apropos-aux theString symtuple indent))
95      (values)))
96 
97#|
98(defun apropos (string &optional package)
99  "Briefly describe all symbols which contain the specified STRING.
100  If PACKAGE is supplied then only describe symbols present in
101  that package. If EXTERNAL-ONLY then only describe
102  external symbols in the specified package."
103  (setq string (string-arg string))
104  (if package
105    (do-symbols (sym package) (apropos-aux string sym))
106    (do-all-symbols (sym) (apropos-aux string sym)))
107  (values))
108
109(defun apropos-aux (string sym &aux val)
110  (when (%apropos-substring-p string (symbol-name sym))
111    (prin1 sym)
112    (when (setq val (fboundp sym))
113      (cond ((functionp val)
114             (princ ", Def: ")
115             (prin1 (type-of val)))
116            ((setq val (macro-function sym))
117             (princ ", Def: MACRO ")
118             (prin1 (type-of val)))
119            (t (princ ", Special form"))))
120    (when (boundp sym)
121       (princ ",  Value: ")
122       (prin1 (symbol-value sym)))
123    (terpri)))
124|#
125
126; (%apropos-substring-p a b)
127; Returns true iff a is a substring (case-sensitive) of b.
128; Internal subroutine of apropos, does no type-checking.  Assumes strings no
129; longer than 64K...
130
131
132
133
134(defun %apropos-substring-p (a b)
135  (let ((charA0 (%schar a 0))
136        (alen (length a))
137        (blen (length b)))
138    (declare (fixnum alen blen) (optimize (speed 3)(safety 0)))
139    (if (= alen 0)  ; "" is substring of every string
140        t
141        (if *apropos-case-sensitive-p*
142            (dotimes (i (the fixnum (%imin blen (%i+ 1 (%i- blen alen)))))
143              (declare (fixnum i))
144              (when (eq (%schar b i) chara0)
145                (when
146                    (do ((j 1 (1+ j)))
147                        ((>= j alen) t)
148                      (declare (fixnum j))
149                      (when (neq (%schar a j)(%schar b (%i+ j i)))
150                        (return nil)))
151                  (return  (%i- blen i alen)))))
152            (dotimes (i (the fixnum (%imin blen (%i+ 1 (%i- blen alen)))))
153              (declare (fixnum i))
154              (when (eq (char-upcase (%schar b i)) (char-upcase chara0))
155                (when
156                    (do ((j 1 (1+ j)))
157                        ((>= j alen) t)
158                      (declare (fixnum j))
159                      (unless (eq (char-upcase (%schar a j)) (char-upcase (%schar b (%i+ j i))))
160                        (return nil)))
161                  (return  (%i- blen i alen)))))))))
162
163
164;;;;;;;;;;;;;;;;;;;;;;;;;;
165;;; from Dave Yost
166(defun find-sym-alpha-part (sym)
167  (let* ((str (prin1-to-string sym))
168         (sortOffset (let ((sym-start (if (find #\: str)
169                                      (loop for ind from (1- (length str)) downto 0
170                                            when (eql #\: (char str ind))
171                                            return (1+ ind))
172                                      0)))
173                     (+ sym-start (find-alpha-char (subseq str sym-start))))))
174    (values str sortOffset sortOffset)))
175
176(defun find-str-in-sym (str sym)
177  (let* ((symStr (string-arg (prin1-to-string sym)))
178         (sortOffset (let ((sym-start (if (find #\: str)
179                                      (loop for ind from (1- (length str)) downto 0
180                                            when (eql #\: (char str ind))
181                                            return (1+ ind))
182                                      0)))
183                     (+ sym-start (find-alpha-char (subseq str sym-start)))))
184         (displayOffset (let ((sym-start (if (find #\: symStr)
185                                       (or (loop for ind from (1- (length symStr)) downto 0
186                                             when (eql #\| (schar symStr ind))
187                                             do (setf ind (loop for ind2 from (1- ind) downto 0
188                                                                when (eql #\| (schar symStr ind2))
189                                                                return ind2))
190                                             when (eql #\: (char symStr ind))
191                                             return (1+ ind))
192                                           0)
193                                       0)))
194                      (+ sym-start (search (string-upcase str) (string-upcase (subseq symStr sym-start)))))))
195    (values symStr sortOffset displayOffset)))
196
197(defun find-alpha-char (str)
198  "returns the character position of the first
199alphabetic character in str, or the length of str
200if it contains no alphabetic characters."
201  (setq str (string-arg str))
202  (dotimes (ind (length str)  ind)
203    (when (alpha-char-p (schar str ind))
204       (return ind))))
205
206(defun sort-symbol-list (theList search-string)
207  ;;; First precompute the stylized string form of the symbols as they will be compared
208  ;;; and calculate the maximum indent
209  (multiple-value-bind (tmpVector indentation)
210                       (let (sortOffset
211                             displayOffset
212                             str)
213                         (loop for x in thelist do
214                           (multiple-value-setq (str sortOffset displayOffset)
215                                    (if search-string
216                                      (find-str-in-sym search-string x)
217                                      (find-sym-alpha-part           x)))
218                           
219                           
220                               maximize displayOffset into indentation1
221                               collect `#(,x ,(string-arg (subseq str sortOffset)) ,sortOffset ,displayOffset) into tmpList1
222                               finally  (return (values `#(,@tmpList1) indentation1))))
223    (sort tmpVector #'(lambda (symPair1 symPair2)
224                       (string-lessp (aref symPair1 1) (aref symPair2 1))))
225    (values tmpVector ; each element is a vector of `#(,sym sortable-string-for-sym)
226            indentation)))
227
228
229#|
230(defun %apropos-substring-p (a b &aux (alen (length a))
231                                     (xlen (%i- (length b) alen)))
232  (if (%iminusp xlen) nil
233    (if (eq alen 0) alen
234      (let ((a0 (schar a 0)) (i 0) j)
235        (tagbody loop
236          (when (eq (schar b i) a0)
237            (setq j 1)
238            (tagbody subloop
239              (when (eq j alen) (return-from %apropos-substring-p i))
240              (when (eq (schar b (%i+ i j)) (schar a j))
241                 (setq j (%i+ j 1))
242                 (go subloop))))
243          (unless (eq i xlen)
244            (setq i (%i+ i 1))
245            (go loop)))
246        nil))))
247|#
Note: See TracBrowser for help on using the repository browser.