/[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.2.2 by camm, Sat Mar 20 01:35:28 2004 UTC revision 1.1.2.2.10.1 by camm, Sat Apr 30 22:39:48 2005 UTC
# Line 11  Line 11 
11    `(slooP::sloop while ,test do ,@ body))    `(slooP::sloop while ,test do ,@ body))
12   (defmacro f (op x y)   (defmacro f (op x y)
13     `(the ,(if  (get op 'compiler::predicate)  't 'fixnum)     `(the ,(if  (get op 'compiler::predicate)  't 'fixnum)
14           (,op (the fixnum ,x) (the fixnum ,y)))))           (,op (the fixnum ,x) (the fixnum ,y))))
15    (defmacro fcr (x) `(load-time-value (compile-regexp ,x))))
16    
17  (eval-when (compile eval load)  (eval-when (compile eval load)
18  (defun sharp-u-reader (stream subchar arg)  (defun sharp-u-reader (stream subchar arg)
# Line 31  Line 32 
32         (vector-push-extend ch tem)))         (vector-push-extend ch tem)))
33      tem))      tem))
34    
   
35  (set-dispatch-macro-character #\# #\u 'sharp-u-reader)  (set-dispatch-macro-character #\# #\u 'sharp-u-reader)
36    
37  )  )
38    
39    (defconstant +crlu+ (compile-regexp #u""))
40    (defconstant +crnp+ (compile-regexp #u"[ ]"))
41    
42  (defvar *info-data* nil)  (defvar *info-data* nil)
43  (defvar *current-info-data* nil)  (defvar *current-info-data* nil)
44    
# Line 67  Line 71 
71    (declare (fixnum lim))    (declare (fixnum lim))
72    (let ((s (file-to-string file)) (i 0))    (let ((s (file-to-string file)) (i 0))
73      (declare (fixnum i) (string s))      (declare (fixnum i) (string s))
74      (cond ((f >= (string-match #u"[ \n]+Indirect:" s 0) 0)      (cond ((f >= (string-match (fcr #u"[ \n]+Indirect:") s 0) 0)
75             (setq i (match-end 0))             (setq i (match-end 0))
76             (setq lim (string-match #u"" s i))             (setq lim (string-match +crlu+ s i))
77             (while             (while
78                 (f >= (string-match #u"\n([^\n]+): ([0-9]+)" s i lim) 0)                 (f >= (string-match (fcr #u"\n([^\n]+): ([0-9]+)") s i lim) 0)
79               (setq i (match-end 0))               (setq i (match-end 0))
80               (setq files               (setq files
81                     (cons(cons                     (cons(cons
# Line 79  Line 83 
83                           (get-match s 1)                           (get-match s 1)
84                           )                           )
85                          files)))))                          files)))))
86      (cond ((f >=  (si::string-match #u"[\n ]+Tag Table:" s i) 0)      (cond ((f >=  (si::string-match (fcr #u"[\n ]+Tag Table:") s i) 0)
87             (setq i (si::match-end 0))             (setq i (si::match-end 0))
88             (cond ((f >= (si::string-match "" s i) 0)             (cond ((f >= (si::string-match +crlu+ s i) 0)
89                    (setq tags (subseq s i (si::match-end 0)))))))                    (setq tags (subseq s i (si::match-end 0)))))))
90      (if files (or tags (info-error "Need tags if have multiple files")))      (if files (or tags (info-error "Need tags if have multiple files")))
91      (list* tags (nreverse files))))      (list* tags (nreverse files))))
92    
93  (defun re-quote-string (x &aux (i 0) (len (length x)) ch  (defun re-quote-string (x &aux (i 0) ch (extra 0))
94                             (extra 0)  )    (declare (fixnum i extra))
95    (declare (fixnum i len extra))    (let ((x (if (stringp x) x (string x))))
96    (declare (string x))      (declare (string x))
97    (let (tem)      (let (tem (len (length x)))
98      (tagbody        (declare (fixnum len))
99       AGAIN        (tagbody
100       (while (< i len)         AGAIN
101         (setq ch (aref x i))         (while (< i len)
102         (cond ((position ch "\\()[]+.*|^$?")           (setq ch (aref x i))
103                (cond (tem           (cond ((position ch "\\()[]+.*|^$?")
104                       (vector-push-extend #\\ tem))                  (cond (tem
105                      (t (incf extra)))))                         (vector-push-extend #\\ tem))
106         (if tem                        (t (incf extra)))))
107             (vector-push-extend ch tem))           (if tem
108         (setq i (+ i 1)))               (vector-push-extend ch tem))
109       (cond (tem )           (setq i (+ i 1)))
110             ((> extra 0)         (cond (tem )
111              (setq tem               ((> extra 0)
112                    (make-array (f + (length x) extra)                (setq tem
113                                :element-type 'string-char :fill-pointer 0))                      (make-array (f + (length x) extra)
114              (setq i 0)                                  :element-type 'string-char :fill-pointer 0))
115              (go AGAIN))                (setq i 0)
116             (t (setq tem x)))                (go AGAIN))
117       )               (t (setq tem x)))
118      tem))         )
119          tem)))
120    
121  (defun get-match (string i)  (defun get-match (string i)
122    (subseq string (match-beginning i) (match-end i)))    (subseq string (match-beginning i) (match-end i)))
# Line 292  Line 297 
297    (let* ((info-subfile (info-subfile n))    (let* ((info-subfile (info-subfile n))
298           (s (info-get-file (cdr info-subfile)))           (s (info-get-file (cdr info-subfile)))
299           (end (- n (car info-subfile))))           (end (- n (car info-subfile))))
300      (while (f >=  (string-match #u"" s i end) 0)      (while (f >=  (string-match +crlu+ s i end) 0)
301        (setq i (match-end 0)))        (setq i (match-end 0)))
302      (setq i (- i 1))      (setq i (- i 1))
303      (if (f >= (string-match      (if (f >= (string-match
304                 #u"[\n ][^\n]*Node:[ \t]+([^\n\t,]+)[\n\t,][^\n]*\n"  s i) 0)                 (fcr #u"[\n ][^\n]*Node:[ \t]+([^\n\t,]+)[\n\t,][^\n]*\n")  s i) 0)
305          (let* ((i (match-beginning 0))          (let* ((i (match-beginning 0))
306                 (beg (match-end 0))                 (beg (match-end 0))
307                 (name (get-match s 1))                 (name (get-match s 1))
308                 (end(if (f >= (string-match "[ ]" s beg) 0)                 (end(if (f >= (string-match +crnp+ s beg) 0)
309                         (match-beginning 0)                         (match-beginning 0)
310                       (length s)))                       (length s)))
311                 (node (list* s beg end i name info-subfile                 (node (list* s beg end i name info-subfile
# Line 326  Line 331 
331             (setq position-pattern (car name) name (cdr name)))))             (setq position-pattern (car name) name (cdr name)))))
332    (or (stringp name) (info-error "bad arg"))    (or (stringp name) (info-error "bad arg"))
333    (waiting *info-window*)      (waiting *info-window*)  
334    (cond ((f >= (string-match "^\\(([^(]+)\\)([^)]*)" name) 0)    (cond ((f >= (string-match (fcr "^\\(([^(]+)\\)([^)]*)") name) 0)
335           ;; (file)node           ;; (file)node
336           (setq file (get-match name 1))           (setq file (get-match name 1))
337           (setq name (get-match name 2))           (setq name (get-match name 2))
# Line 351  Line 356 
356                      s start) 0)                      s start) 0)
357               (let* ((i (match-beginning 0))               (let* ((i (match-beginning 0))
358                      (beg (match-end 0))                      (beg (match-end 0))
359                      (end(if (f >= (string-match "[ ]" s beg) 0)                      (end(if (f >= (string-match +crnp+ s beg) 0)
360                              (match-beginning 0)                              (match-beginning 0)
361                            (length s)))                            (length s)))
362                      (node (list* s beg end i name info-subfile                      (node (list* s beg end i name info-subfile
# Line 366  Line 371 
371                          (f >= (setq subnode                          (f >= (setq subnode
372                                      (string-match                                      (string-match
373                                       (si::string-concatenate                                       (si::string-concatenate
374                                        #u"\n - [A-Za-z ]+: "                                        #u"\n -+ [A-Za-z ]+: "
375                                        position-pattern #u"[ \n]")                                        position-pattern #u"[ \n]")
376                                       s beg end)) 0)                                       s beg end)) 0)
377                          (f >= (string-match position-pattern s beg end) 0))                          (f >= (string-match position-pattern s beg end) 0))
# Line 381  Line 386 
386                        (let ((e                        (let ((e
387                               (if (and (>= subnode 0)                               (if (and (>= subnode 0)
388                                        (f >=                                        (f >=
389                                           (string-match #u"\n\n - [A-Z]"                                           (string-match
390                                                         s (+ beg 1                                            (fcr #u"\n -+ [a-zA-Z]")
391                                                              initial-offset)                                            s
392                                              (let* ((bg (+ beg 1 initial-offset))
393                                                     (sd (string-match (fcr #u"\n   ") s bg end))
394                                                     (nb (if (minusp sd) bg sd)))
395                                                nb)
396                                                         end)                                                         end)
397                                           0))                                           0))
398                                   (match-beginning 0)                                   (match-beginning 0)

Legend:
Removed from v.1.1.2.2  
changed lines
  Added in v.1.1.2.2.10.1

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