/[gcl]/gcl/lsp/gcl_info.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_info.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:05 2003 UTC
# Line 0  Line 1 
1    (in-package "SI"  )
2    
3    (eval-when (compile)
4    
5    
6    (proclaim '(ftype (function (t t &optional fixnum) fixnum) string-match))
7    (proclaim '(ftype (function (fixnum) fixnum)
8                      match-beginning match-end)))
9    (eval-when (compile eval)
10    (defmacro while (test &body body)
11      `(slooP::sloop while ,test do ,@ body))
12     (defmacro f (op x y)
13       `(the ,(if  (get op 'compiler::predicate)  't 'fixnum)
14             (,op (the fixnum ,x) (the fixnum ,y)))))
15    
16    (eval-when (compile eval load)
17    (defun sharp-u-reader (stream subchar arg)
18      subchar arg
19      (let ((tem (make-array 10 :element-type 'string-char :fill-pointer 0)))
20        (or (eql (read-char stream) #\")
21            (error "sharp-u-reader reader needs a \" right after it"))
22        (loop
23         (let ((ch (read-char stream)))
24           (cond ((eql ch #\") (return tem))
25                 ((eql ch #\\)
26                  (setq ch (read-char stream))
27                  (setq ch (or (cdr (assoc ch '((#\n . #\newline)
28                                                (#\t . #\tab)
29                                                (#\r . #\return))))
30                               ch))))
31           (vector-push-extend ch tem)))
32        tem))
33    
34    
35    (set-dispatch-macro-character #\# #\u 'sharp-u-reader)
36    )
37    
38    (defvar *info-data* nil)
39    (defvar *current-info-data* nil)
40    
41    (defun file-to-string (file &optional (start 0)
42                                &aux (si::*ALLOW-GZIPPED-FILE* t)(len 0))
43      (with-open-file
44       (st file)
45       (setq len (file-length st))
46       (or (and (<= 0 start ) (<= start len))
47           (error "illegal file start ~a" start))
48       (let ((tem (make-array (- len start)
49                              :element-type 'string-char)))
50         (if (> start 0) (file-position st start))
51         (si::fread tem 0 (length tem) st) tem)))
52    
53    (defun atoi (string start &aux (ans 0) (ch 0)(len (length string)))
54      (declare (string string))
55      (declare (fixnum start ans ch len) )
56      (while (< start len)
57        (setq ch (char-code (aref string start)))
58        (setq start (+ start 1))
59        (setq ch (- ch #.(char-code #\0)))
60        (cond ((and (>= ch 0) (< ch 10))
61               (setq ans (+ ch (* 10 ans))))
62              (t (return nil))))
63      ans))
64      
65    (defun info-get-tags (file &aux (lim 0) *match-data* tags files
66                               (*case-fold-search* t))
67      (declare (fixnum lim))
68      (let ((s (file-to-string file)) (i 0))
69        (declare (fixnum i) (string s))
70        (cond ((f >= (string-match #u"[ \n]+Indirect:" s 0) 0)
71               (setq i (match-end 0))
72               (setq lim (string-match #u"" s i))
73               (while
74                   (f >= (string-match #u"\n([^\n]+): ([0-9]+)" s i lim) 0)
75                 (setq i (match-end 0))
76                 (setq files
77                       (cons(cons
78                             (atoi s (match-beginning 2))
79                             (get-match s 1)
80                             )
81                            files)))))
82        (cond ((f >=  (si::string-match #u"[\n ]+Tag Table:" s i) 0)
83               (setq i (si::match-end 0))
84               (cond ((f >= (si::string-match "" s i) 0)
85                      (setq tags (subseq s i (si::match-end 0)))))))
86        (if files (or tags (info-error "Need tags if have multiple files")))
87        (list* tags (nreverse files))))
88    
89    (defun re-quote-string (x &aux (i 0) (len (length x)) ch
90                               (extra 0)  )
91      (declare (fixnum i len extra))
92      (declare (string x))
93      (let (tem)
94        (tagbody
95         AGAIN
96         (while (< i len)
97           (setq ch (aref x i))
98           (cond ((position ch "\\()[]+.*|^$?")
99                  (cond (tem
100                         (vector-push-extend #\\ tem))
101                        (t (incf extra)))))
102           (if tem
103               (vector-push-extend ch tem))
104           (setq i (+ i 1)))
105         (cond (tem )
106               ((> extra 0)
107                (setq tem
108                      (make-array (f + (length x) extra)
109                                  :element-type 'string-char :fill-pointer 0))
110                (setq i 0)
111                (go AGAIN))
112               (t (setq tem x)))
113         )
114        tem))
115    
116    (defun get-match (string i)
117      (subseq string (match-beginning i) (match-end i)))
118    
119    (defun get-nodes (pat node-string &aux (i 0) ans
120                          (*case-fold-search* t) *match-data*)
121      (declare (fixnum i))
122      (when node-string
123            (setq pat
124                  (si::string-concatenate "Node: ([^]*" (re-quote-string
125                                                           pat) "[^]*)"))
126            (while (f >= (string-match pat node-string i) 0)
127              (setq i (match-end 0))
128              (setq ans (cons (get-match node-string 1)
129                              ans))
130              )
131            (nreverse ans)))
132    
133    (defun get-index-node ()
134     (or (third *current-info-data*)
135         (let* (
136                s
137                (node-string (car (nth 1 *current-info-data*)))
138                (node
139                 (and node-string (car (get-nodes "index" node-string)))))
140           (when node
141               (setq s (show-info
142                        node
143                        nil
144                        nil
145                        ))
146            (setf (third *current-info-data*) s)))))
147    
148    (defun nodes-from-index (pat  &aux (i 0) ans
149                                  (*case-fold-search* t) *match-data*)
150      (let ((index-string (get-index-node)))
151        (when index-string
152        (setq pat
153              (si::string-concatenate #u"\n\\* ([^:\n]*" (re-quote-string
154                                                      pat)
155                                      #u"[^:\n]*):[ \t]+([^\t\n,.]+)"))
156        (while (f >= (string-match pat index-string i) 0)
157          (setq i (match-end 0))
158          (setq ans (cons (cons (get-match index-string 1)
159                                (get-match index-string 2))
160                              
161                              
162                          ans))
163          )
164        (nreverse ans))))
165    
166    (defun get-node-index (pat node-string &aux (node pat) *match-data*)
167      (cond ((null node-string) 0)
168            (t
169             (setq pat
170                   (si::string-concatenate "Node: "
171                                           (re-quote-string pat) "([0-9]+)"))
172             (cond ((f >= (string-match pat node-string) 0)
173                    (atoi node-string (match-beginning 1)))
174                   (t (info-error "cant find node ~s" node) 0)))))
175    
176    (defun all-matches (pat st &aux (start 0) *match-data*)
177      (declare (fixnum start))
178       (sloop::sloop while (>= (setq start (si::string-match pat st start)) 0)
179             do nil;(print start)
180             collect (list start (setq start (si::match-end 0)))))
181    
182    
183    
184    (defmacro node (prop x)
185      `(nth ,(position prop '(string begin end header name
186                                     info-subfile
187                                     file tags)) ,x))
188    
189    (defun node-offset (node)
190      (+ (car (node info-subfile node)) (node begin node)))
191    
192    (defvar *info-paths*
193      '("" "/usr/info/" "/usr/local/lib/info/" "/usr/local/info/"
194        "/usr/local/gnu/info/" "/usr/share/info/"))
195    
196    (defvar *old-lib-directory* nil)
197    (defun setup-info (name &aux tem file)
198      (or (eq *old-lib-directory* si::*lib-directory*)
199          (progn
200            (setq *old-lib-directory* si::*lib-directory*)
201            (push (si::string-concatenate
202                   si::*lib-directory* "info/") *info-paths*)
203            (setq *info-paths* (si::fix-load-path *info-paths*))))
204      (cond ((or (equal name "DIR"))
205             (setq name "dir")))
206    ;; compressed info reading -- search for gzipped files, and open with base filename
207    ;; relying on si::*allow-gzipped-files* to uncompress
208      (setq file (si::file-search name *info-paths* '("" ".info" ".gz") nil))
209      (let ((ext (search ".gz" file)))
210        (when ext
211          (setq file (subseq file 0 ext))))
212      (cond ((and (null file)
213                  (not (equal name "dir")))
214             (let* (
215                    (tem (show-info "(dir)Top" nil nil))
216                   *case-fold-search*)
217               (cond ((f >= (string-match
218                (si::string-concatenate
219                "\\(([^(]*"
220                 (re-quote-string name)
221                 "(.info)?)\\)")
222                tem ) 0)
223                     (setq file  (get-match tem 1)))))))
224      (cond (file
225             (let* ((na (namestring (truename file))))
226               (cond ((setq tem (assoc na *info-data* :test 'equal))
227                      (setq *current-info-data* tem))
228                     (t   (setq *current-info-data*
229                                (list na (info-get-tags na) nil))
230                          (setq *info-data* (cons *current-info-data* *info-data*)
231                                )))))
232            (t (format t "(not found ~s)" name)))
233      nil)
234                              
235    (defun get-info-choices (pat type)
236          (if (eql type 'index)
237              (nodes-from-index pat )
238            (get-nodes pat (car (nth 1 *current-info-data*))))))
239    
240    (defun add-file (v file &aux (lis v))
241      (while lis
242        (setf (car lis) (list (car lis) file))
243        (setq lis (cdr lis)))
244      v)
245    
246    (defvar *info-window* nil)
247    (defvar *tk-connection* nil)
248    
249    (defun info-error (&rest l)
250      (if *tk-connection*
251          (tk::tkerror (apply 'format nil l))
252        (apply 'error l)))
253    
254    (defvar *last-info-file* nil)
255    ;; cache last file read to speed up lookup since may be gzipped..
256    (defun info-get-file (pathname)
257      (setq pathname
258            (merge-pathnames pathname
259                             (car *current-info-data*)))
260      (cdr
261       (cond ((equal (car *last-info-file*) pathname)
262              *last-info-file*)
263             (t (setq *last-info-file*
264                      (cons pathname (file-to-string pathname)))))))
265    
266    (defun waiting (win)
267      (and *tk-connection*
268           (fboundp win)
269           (winfo :exists win :return 'boolean)
270           (funcall win :configure :cursor "watch")))
271    
272    (defun end-waiting (win) (and (fboundp win)
273                               (funcall win :configure :cursor "")))
274    
275    (defun info-subfile (n  &aux )
276    ;  "For an index N return (START . FILE) for info subfile
277    ; which contains N.   A second value bounding the limit if known
278    ; is returned.   At last file this limit is nil."
279      (let ((lis (cdr (nth 1 *current-info-data*)))
280            ans lim)
281        (and lis (>= n 0)
282               (dolist (v lis)
283                     (cond ((> (car v) n )
284                            (setq lim (car v))
285                            (return nil)))
286                     (setq ans v)
287                     ))
288        (values (or ans (cons 0 (car *current-info-data*))) lim)))
289    
290    ;;used by search
291    (defun info-node-from-position (n &aux  (i 0))
292      (let* ((info-subfile (info-subfile n))
293             (s (info-get-file (cdr info-subfile)))
294             (end (- n (car info-subfile))))
295        (while (f >=  (string-match #u"" s i end) 0)
296          (setq i (match-end 0)))
297        (setq i (- i 1))
298        (if (f >= (string-match
299                   #u"[\n ][^\n]*Node:[ \t]+([^\n\t,]+)[\n\t,][^\n]*\n"  s i) 0)
300            (let* ((i (match-beginning 0))
301                   (beg (match-end 0))
302                   (name (get-match s 1))
303                   (end(if (f >= (string-match "[ ]" s beg) 0)
304                           (match-beginning 0)
305                         (length s)))
306                   (node (list* s beg end i name info-subfile
307                                     *current-info-data*)))
308              node))))
309        
310    (defun show-info (name  &optional position-pattern
311                            (use-tk *tk-connection*)
312                            &aux info-subfile *match-data*
313                            file
314                           (initial-offset 0)(subnode -1))
315      (declare (fixnum subnode initial-offset))
316    ;;; (pat . node)
317    ;;; node
318    ;;; (node file)
319    ;;; ((pat . node) file)
320    ;  (print (list name position-pattern use-tk))
321      (progn ;decode name
322        (cond ((and (consp name) (consp (cdr name)))
323               (setq file (cadr name)
324                     name (car name))))
325        (cond ((consp name)
326               (setq position-pattern (car name) name (cdr name)))))
327      (or (stringp name) (info-error "bad arg"))
328      (waiting *info-window*)  
329      (cond ((f >= (string-match "^\\(([^(]+)\\)([^)]*)" name) 0)
330             ;; (file)node
331             (setq file (get-match name 1))
332             (setq name (get-match name 2))
333             (if (equal name "")(setq name "Top"))))
334      (if file  (setup-info file))
335      (let ((indirect-index (get-node-index name
336                                            (car (nth 1 *current-info-data*)))))
337        (cond ((null  indirect-index)
338               (format t"~%Sorry, Can't find node ~a" name)
339               (return-from show-info nil)))
340            
341        (setq info-subfile (info-subfile indirect-index))
342        (let* ((s
343                (info-get-file (cdr info-subfile)))
344               (start (- indirect-index (car info-subfile))))
345          (cond ((f >= (string-match
346                        ;; to do fix this ;; see (info)Add  for description;
347                        ;;  the
348                        (si::string-concatenate
349                         #u"[\n ][^\n]*Node:[ \t]+"
350                         (re-quote-string name) #u"[,\t\n][^\n]*\n")
351                        s start) 0)
352                 (let* ((i (match-beginning 0))
353                        (beg (match-end 0))
354                        (end(if (f >= (string-match "[ ]" s beg) 0)
355                                (match-beginning 0)
356                              (length s)))
357                        (node (list* s beg end i name info-subfile
358                                     *current-info-data*)))
359    
360                   (cond
361                    (position-pattern
362                     (setq position-pattern (re-quote-string position-pattern))
363    
364                     (let (*case-fold-search* )
365                       (if (or
366                            (f >= (setq subnode
367                                        (string-match
368                                         (si::string-concatenate
369                                          #u"\n - [A-Za-z ]+: "
370                                          position-pattern #u"[ \n]")
371                                         s beg end)) 0)
372                            (f >= (string-match position-pattern s beg end) 0))
373                           (setq initial-offset
374                                 (- (match-beginning 0) beg))
375                         ))))
376                   (cond ( use-tk
377                           (prog1 (print-node node initial-offset)
378                             (end-waiting  *info-window*))
379                           )
380                         (t
381                          (let ((e
382                                 (if (and (>= subnode 0)
383                                          (f >=
384                                             (string-match #u"\n\n - [A-Z]"
385                                                           s (+ beg 1
386                                                                initial-offset)
387                                                           end)
388                                             0))
389                                     (match-beginning 0)
390                                   end)))
391                            ;(print (list  beg initial-offset e end))
392                            (subseq s (+ initial-offset beg) e )
393                            ;s
394                            )))))
395                (t (info-error "Cant find node  ~a?" name)
396                   (end-waiting  *info-window*)
397                   ))
398                )))
399    
400    (defvar *default-info-files* '( "gcl-si.info" "gcl-tk.info" "gcl.info"))
401    
402    (defun info-aux (x dirs)
403      (sloop for v in dirs
404                        do (setup-info v)
405                        append (add-file (get-info-choices x 'node) v)
406                        append (add-file (get-info-choices x 'index) v)))
407    
408    (defun info-search (pattern &optional start end &aux limit)
409    ;  "search for PATTERN from START up to END where these are indices in
410    ;the general info file.   The search goes over all files."
411      (or start (setq start 0))
412      (while start
413        (multiple-value-bind
414         (file lim)
415         (info-subfile start)
416         (setq limit lim)
417         (and end limit (<  end limit) (setq limit end))
418    
419         (let* ((s  (info-get-file (cdr  file)))
420               (beg (car file))
421               (i (- start beg))
422               (leng (length s)))
423           (cond ((f >= (string-match pattern s i (if limit (- limit beg) leng)) 0)
424                  (return-from info-search (+ beg (match-beginning 0))))))
425         (setq start lim)))
426      -1)
427    
428    #+debug ; try searching
429    (defun try (pat &aux (tem 0) s )
430     (while (>= tem 0)
431      (cond ((>= (setq tem (info-search pat tem)) 0)
432             (setq s (cdr *last-info-file*))
433             (print (list
434                     tem
435                     (list-matches s 0 1 2)
436                     (car *last-info-file*)
437                     (subseq s
438                             (max 0 (- (match-beginning 0) 50))
439                             (min (+ (match-end 0) 50) (length s)))))
440             (setq tem (+ tem (- (match-end 0) (match-beginning 0))))))))
441      
442    (defun idescribe (name)
443        (let* ((items (info-aux name *default-info-files*)))
444          (dolist (v items)
445                  (when (cond ((consp (car v))
446                               (equalp (caar v) name))
447                              (t (equalp (car v) name)))
448                    (format t "~%From ~a:~%" v)
449                    (princ (show-info v nil nil))))))
450      
451    (defun info (x &optional (dirs *default-info-files*)  &aux wanted
452                   *current-info-data* file position-pattern)
453      (let ((tem (info-aux x dirs)))
454        (cond
455         (*tk-connection*
456          (offer-choices tem dirs)
457           )
458         (t
459    
460        (when tem
461          (let ((nitems (length tem)))
462              (sloop for i from 0 for name in tem with prev
463                     do (setq file nil position-pattern nil)
464                     (progn ;decode name
465                       (cond ((and (consp name) (consp (cdr name)))
466                              (setq file (cadr name)
467                                    name (car name))))
468                       (cond ((consp name)
469                              (setq position-pattern (car name) name (cdr name)))))
470                     (format t "~% ~d: ~@[~a :~]~@[(~a)~]~a." i
471                             position-pattern
472                             (if (eq file prev) nil (setq prev file)) name))
473              (if (> (length tem) 1)
474                (format t "~%Enter n, all, none, or multiple choices eg 1 3 : ")
475                (terpri))
476              (let ((line (if (> (length tem) 1) (read-line) "0"))
477                    (start 0)
478                    val)
479                (while (equal line "") (setq line (read-line)))
480                (while (multiple-value-setq
481                        (val start)
482                        (read-from-string line nil nil :start start))
483                  (cond ((numberp val)
484                         (setq wanted (cons val wanted)))
485                        (t (setq wanted val) (return nil))))
486                (cond ((consp wanted)(setq wanted (nreverse wanted)))
487                      ((symbolp wanted)
488                       (setq wanted (and
489                                     (equal (symbol-name wanted) "ALL")
490                                     (sloop for i below (length tem) collect i)))))
491                (when wanted
492                  ;; Remove invalid (numerical) answers
493                  (setf wanted (remove-if #'(lambda (x)
494                                              (and (integerp x) (>= x nitems)))
495                                          wanted))
496                  (format t "~%Info from file ~a:" (car *current-info-data*)))
497                (sloop for i in wanted
498                       do (princ(show-info (nth i tem)))))))))))
499    
500                
501    ;; idea make info_text window have previous,next,up bindings on keys
502    ;; and on menu bar.    Have it bring up apropos menu. allow selection
503    ;; to say spawn another info_text window.   The symbol that is the window
504    ;; will carry on its plist the prev,next etc nodes, and the string-to-file
505    ;; cache the last read file as well.   Add look up in index file, so that can
506    ;; search an indtqex as well.   Could be an optional arg to show-node
507    ;;
508    
509    
510    
511    (defun default-info-hotlist()
512      (namestring (merge-pathnames "hotlist" (user-homedir-pathname))))
513    
514    (defvar *info-window* nil)
515    
516    (defun add-to-hotlist (node )
517      (if (symbolp node) (setq node (get node 'node)))
518      (cond
519       (node
520        (with-open-file
521         (st (default-info-hotlist)
522             :direction :output
523             :if-exists :append
524             :if-does-not-exist :create)
525         (cond ((< (file-position st) 10)
526                (princ  #u"\nFile:\thotlist\tNode: Top\n\n* Menu: Hot list of favrite info items.\n\n" st)))
527         (format st "* (~a)~a::~%"
528                 (node file node)(node name node))))))
529    
530    (defun list-matches (s &rest l)
531      (sloop for i in l
532             collect
533             (and (f >= (match-beginning i) 0)
534                  (get-match s i))))
535    
536    ;;; Local Variables: ***
537    ;;; mode:lisp ***
538    ;;; version-control:t ***
539    ;;; comment-column:0 ***
540    ;;; comment-start: ";;; " ***
541    ;;; End: ***
542    
543    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26