source: branches/qres/ccl/lib/apropos.lisp @ 14259

Last change on this file since 14259 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

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