1
;; Copyright (C) 1994 W. Schelter
3
;; This file is part of GNU Common Lisp, herein referred to as GCL
5
;; GCL is free software; you can redistribute it and/or modify it under
6
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
7
;; the Free Software Foundation; either version 2, or (at your option)
10
;; GCL is distributed in the hope that it will be useful, but WITHOUT
11
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
12
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
13
;; License for more details.
20
(eval-when (compile eval)
22
`(the ,(if (get op 'compiler::predicate) 't 'fixnum)
23
(,op (the fixnum ,x) (the fixnum ,y))))
24
(defmacro while (test &body body)
25
`(sloop while ,test do ,@ body))
27
(or (boundp '*info-window*)
30
(defun simple-listbox (w)
31
(let ((listbox (conc w '.frame.list))
32
(scrollbar(conc w '.frame.scroll)))
33
(frame (conc w '.frame))
34
(scrollbar scrollbar :relief "sunken" :command
35
(tk-conc w ".frame.list yview"))
36
(listbox listbox :yscroll (tk-conc w ".frame.scroll set")
39
(pack scrollbar :side "right" :fill "y")
40
(pack listbox :side "left" :expand "yes" :fill "both"))
44
(defun insert-standard-listbox (w lis &aux print-entry)
45
(funcall w :delete 0 'end)
46
(setf (get w 'list) lis)
47
(setq print-entry (get w 'print-entry))
49
(funcall w :insert 'end
50
(if print-entry (funcall print-entry v) v))))
52
(defun listbox-move (win key |%y|)
54
(let ((amt (cdr (assoc key '(("Up" . -1)
61
(+ (funcall win :nearest 0 :return 'number) amt))))))
63
(defun new-window (name &aux tem)
64
(cond ((not (fboundp name)) name)
65
((winfo :exists name :return 'boolean)
67
(while (winfo :exists (setq tem (conc name i )) :return 'boolean)
73
(defun insert-info-choices (listbox list &aux file position-pattern prev)
74
(funcall listbox :delete 0 'end)
75
(sloop for i from 0 for name in list
76
do (setq file nil position-pattern nil)
78
(cond ((and (consp name) (consp (cdr name)))
79
(setq file (cadr name)
82
(setq position-pattern (car name) name (cdr name)))))
83
(funcall listbox :insert 'end
84
(format nil "~@[~a :~]~@[(~a)~]~a."
86
(if (eq file prev) nil (setq prev file)) name)))
87
(setf (get listbox 'list)list))
89
(defun offer-choices (list info-dirs &optional (w (new-window '.info))
93
(setq listbox (conc w '.frame.list))
94
(insert-info-choices listbox list)
95
(bind listbox "<Double-1>"
98
(nth (atoi (funcall listbox :curselection :return 'string)
100
(get listbox 'list)))))
101
(button (conc w '.ok) :text "Quit " :command `(destroy ',w))
102
(frame (conc w '.apro))
103
(label(conc w '.apro.label) :text "Apropos: ")
104
(entry (conc w '.apro.entry) :relief "sunken")
105
(pack (conc w '.apro.label) (conc w '.apro.entry) :side "left"
108
(conc w '.frame) (conc w '.ok)
109
(conc w '.apro) :side "top" :fill "both")
110
(bind (conc w '.apro.entry) "<KeyPress-Return>"
114
(info-aux (funcall (conc w '.apro.entry)
115
:get :return 'string)
118
(bind w "<Enter>" `(focus ',(conc w '.apro.entry)))
123
(defun get-info-apropos (win file type)
125
(winfo :exists win :return 'boolean))
126
(let ((old (get win 'info-data)))
127
(unless (eq old *current-info-data*)
128
(setf (get win 'info-data) *current-info-data*)
129
(funcall (conc win '.frame.list) :delete 0 'end))
133
(t (offer-choices file type nil))))
134
(defun show-info-key (win key)
135
(let ((node (get win 'node)) name)
136
(or node (info-error "No Node?"))
139
(si::string-concatenate key
140
#u":[ \t]+([^\n\t,]+)[\n\t,]")
145
(get-match (node string node) 1)))
146
(if name (show-info name nil))))
147
(defun mkinfo (&optional (w '.info_text) &aux textwin menu
149
(if (winfo :exists w :return 'boolean) (destroy w))
151
(wm :title w "Info Text Window")
152
(wm :iconname w "Info")
153
(frame (setq menu (conc w '.menu )):relief "raised" :borderwidth 1)
154
(setq textwin (conc w '.t))
155
(pack menu :side "top" :fill "x")
156
(button (conc menu '.quit) :text "Quit" :command
159
(menubutton (conc menu '.file) :text "File" :relief 'raised
160
:menu (conc menu '.File '.m) :underline 0)
161
(menu (conc menu '.file '.m))
162
(funcall (conc menu '.file '.m)
165
:command '(show-info (tk-conc "("(default-info-hotlist)
168
(funcall (conc menu '.file '.m)
170
:label "Add to Hotlist"
171
:command `(add-to-hotlist ',textwin))
172
(funcall (conc menu '.file '.m)
175
:command `(show-info "(dir)" nil))
177
(button (conc menu '.next) :text "Next" :relief 'raised
178
:command `(show-info-key ',textwin "Next"))
179
(button (conc menu '.prev) :text "Previous" :relief 'raised
180
:command `(show-info-key ',textwin "Prev"))
181
(button (conc menu '.up) :text "Up" :relief 'raised
182
:command `(show-info-key ',textwin "Up"))
183
(button (conc menu '.info) :text "Info" :relief 'raised
184
:command `(if (winfo :exists ".info")
186
(offer-choices nil si::*default-info-files*)
188
(button (conc menu '.last) :text "Last" :relief 'raised
189
:command `(info-show-history ',textwin 'last))
190
(button (conc menu '.history) :text "History" :relief 'raised
191
:command `(info-show-history ',textwin 'history))
193
(pack (conc menu '.file)
194
(conc menu '.quit) (conc menu '.next) (conc menu '.prev)
195
(conc menu '.up) (conc menu '.prev)
196
(conc menu '.last) (conc menu '.history) (conc menu '.info)
198
; (entry (conc menu '.entry) :relief "sunken")
199
; (pack (conc menu '.entry) :expand "yes" :fill "x")
201
; (pack (conc menu '.next)
205
(bind w "<Enter>" `(focus ',menu))
207
; (tk-menu-bar menu (conc menu '.next) )
208
; (bind menu "<Any-M-KeyPress>" "tk_traverseToMenu %W %A")
209
(scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview"))
210
(text textwin :relief "raised" :bd 2
213
(funcall textwin :configure
215
(scroll-set-fix-xref-closure
220
(bind menu "<KeyPress-n>" `(show-info-key ',textwin "Next"))
221
(bind menu "<KeyPress-u>" `(show-info-key ',textwin "Up"))
222
(bind menu "<KeyPress-p>" `(show-info-key ',textwin "Prev"))
223
(bind menu "<KeyPress-l>" (nth 4(funcall (conc menu '.last)
224
:configure :command :return
227
;; SEARCHING: this needs to be speeded up and fixed.
228
; (bind (conc menu '.entry) "<KeyPress>"
229
; `(info-text-search ',textwin ',menu %W %A %K))
230
; (bind (conc menu '.entry) "<Control-KeyPress>"
231
; `(info-text-search ',textwin ',menu %W %A %K))
233
; (bind menu "<KeyPress-s>" #'(lambda () (focus (menu '.entry))))
238
(pack (conc w '.s) :side 'right :fill "y")
239
(pack textwin :expand 'yes :fill 'both)
240
(funcall textwin :mark 'set 'insert 0.0)
241
(funcall textwin :tag :configure 'bold
242
:font :Adobe-Courier-Bold-O-Normal-*-120-*)
243
(funcall textwin :tag :configure 'big :font
244
:Adobe-Courier-Bold-R-Normal-*-140-*)
245
(funcall textwin :tag :configure 'verybig :font
246
:Adobe-Helvetica-Bold-R-Normal-*-240-*)
247
(funcall textwin :tag :configure 'xref
248
:font :Adobe-Courier-Bold-O-Normal-*-120-* )
249
(funcall textwin :tag :configure 'current_xref
251
(funcall textwin :tag :bind 'xref "<Enter>"
252
"eval [concat %W { tag add current_xref } [get_tag_range %W xref @%x,%y]]")
254
(funcall textwin :tag :bind 'xref "<Leave>"
255
"%W tag remove current_xref 0.0 end")
256
(funcall textwin :tag :bind 'xref "<3>"
257
`(show-this-node ',textwin |%x| |%y|))
259
;; (bind w "<Any-Enter>" (tk-conc "focus " w ".t"))
263
(defun info-text-search (textwin menu entry a k &aux again
264
(node (get textwin 'node)))
265
(or node (tk-error "cant find node index"))
266
; (print (list entry a k ))
267
(cond ((equal k "Delete")
268
(let ((n (funcall entry :index 'insert :return 'number)))
269
(funcall entry :delete (- n 1))))
270
((>= (string-match "Control" k) 0))
271
((equal a "") (setq again 1))
272
((>= (string-match "[^-]" a) 0)
273
(funcall entry :insert 'insert a) (setq again 0))
275
(or again (return-from info-text-search nil))
276
(print (list 'begin-search entry a k ))
279
(ind (funcall textwin :index 'current :return 'string))
280
(pos (index-to-position ind
287
(info-search (funcall entry :get :return 'string)
288
(+ again (node-offset node) pos))))
289
;; to do mark region in reverse video...
291
(let ((node (info-node-from-position where)))
292
(print-node node (- where (node-offset node)))))
293
(t (funcall entry :flash )))))
295
(defvar *last-history* nil)
296
(defun print-node (node initial-offset &aux last)
297
; "print text from node possibly positioning window at initial-offset
298
;from beginning of node"
300
(setq last (list node initial-offset))
301
(let ((text '.info_text) textwin tem)
302
(or (winfo :exists text :return 'boolean)
305
textwin (conc text '.t))
306
(funcall textwin :configure :state 'normal)
307
(cond ((get textwin 'no-record-history)
308
(remprop textwin 'no-record-history))
309
((setq tem (get textwin 'node))
310
(setq *last-history* nil)
312
(format nil #u"* ~a:\t(~a)~a.\tat:~a"
316
(funcall textwin :index "@0,0" :return 'string)
318
(get textwin 'history))))
319
(setf (get textwin 'node) node)
320
(funcall textwin :delete 0.0 'end)
321
(funcall textwin :mark :set 'insert "1.0")
322
(cond ((> initial-offset 0)
323
;; insert something to separate the beginning of what
324
;; we want to show and what goes before.
325
(funcall textwin :insert "0.0" #u"\n")
326
(funcall textwin :mark :set 'display_at 'end)
327
(funcall textwin :mark :set 'insert 'end)
328
(funcall textwin :yview 'display_at)
329
(insert-fontified textwin (node string node)
330
(+ (node begin node) initial-offset)
332
(funcall textwin :mark :set 'insert "0.0")
333
(insert-fontified textwin (node string node)
335
(+ (node begin node) initial-offset))
338
(insert-fontified textwin (node string node)
341
(funcall textwin :configure :state 'disabled)
348
(defun info-show-history (win type)
349
(let ((his (get win 'history)))
350
(cond ((stringp type)
351
(if (f >= (string-match #u":\t([^\t]+)[.]\tat:([0-9.]+)" type) 0)
352
(let ((pos (get-match type 2))
353
(w (show-info (get-match type 1) nil)))
354
(setf (get win 'no-record-history) t)
355
(or (equal "1.0" pos)
356
(funcall w :yview pos)))))
358
(info-show-history win (if *last-history*
360
(progn (setq *last-history*
362
(pop *last-history*)))))
364
(let* ((w '.info_history)
365
(listbox (conc w '.frame.list)))
366
(cond ((winfo :exists w :return 'boolean))
370
(button (conc w '.quit) :text "Quit" :command
372
(pack (conc w '.frame) (conc w '.quit)
373
:expand "yes" :fill 'both)
375
(insert-standard-listbox listbox his)
377
(bind listbox "<Double-1>" `(info-show-history
381
'list-strings)))))))))
385
(defun show-this-node (textwin x y)
386
(let ((inds (get_tag_range textwin 'xref "@": x :",": y :return
388
(cond ((and inds (listp inds) (eql (length inds) 2))
389
(show-info (nsubstitute #\space #\newline
390
(apply textwin :get :return 'string inds))
394
(defun scroll-set-fix-xref-closure (wint wins &aux prev)
399
(apply wins :set l)))))
402
(defvar *recursive* nil)
404
;(defun fix-xref-faster (win &aux (all'(" ")) tem)
407
; (let* ((*recursive* t) s
408
; (pat #u"\n\\* ([^:\n]+)::|\n\\* [^:\n]+:[ \t]*(\\([^,\n\t]+\\)[^,.\n\t]*)[^\n]?|\n\\* [^:\n]+:[ \t]*([^,(.\n\t]+)[^\n]?")
409
; (beg (funcall win :index "@0,0 linestart -1 char" :return 'string))
410
; (end (funcall win :index "@0,1000 lineend" :return 'string)))
411
; (cond ((or (f >= (string-match "possible_xref"
412
; (funcall win :tag :names beg :return 'string)) 0)
414
; (setq tem (funcall win :tag :nextrange "possible_xref" beg end
415
; :return 'string)))))
416
; (if tem (setq beg (car (list-string tem))))
417
; (let ((s (funcall win :get beg end :return 'string))
420
; (pp "MultipleTagAdd" no_quote)
425
; (while (f >= (string-match pat s j) 0)
426
; (setq i (if (f >= (match-beginning 1) 0) 1 2))
427
; (pp (match-beginning i) no_quote)
428
; (pp (match-end i) no_quote)
429
; (setq j (match-end 0))
432
; (send-tcl-cmd *tk-connection* tk-command nil)))
433
; (funcall win :tag :remove "possible_xref" beg end)
436
(defun fix-xref (win &aux tem)
439
(let* ((*recursive* t)
440
(pat #u"\n\\* ([^:\n]+)::|\n\\* [^:\n]+:[ \t]*(\\([^,\n\t]+\\)[^,.\n\t]*)[^\n]?|\n\\* [^:\n]+:[ \t]*([^,(.\n\t]+)[^\n]?")
441
(beg (funcall win :index "@0,0 linestart -1 char" :return 'string))
442
(end (funcall win :index "@0,1000 lineend" :return 'string)))
443
(cond ((or (f >= (string-match "possible_xref"
444
(funcall win :tag :names beg :return 'string)) 0)
446
(setq tem (funcall win :tag :nextrange
447
"possible_xref" beg end
449
(if tem (setq beg (car (list-string tem))))
450
(let ((s (funcall win :get beg end :return 'string))
452
(while (f >= (string-match pat s j) 0)
454
(if (f >= (match-beginning 1) 0) 1
455
(if (f >= (match-beginning 2) 0) 2
457
(funcall win :tag :add "xref"
458
beg : "+" : (match-beginning i) : " chars"
459
beg : "+" : (match-end i) : " chars")
460
(setq j (match-end 0))))
461
(funcall win :tag :remove "possible_xref" beg end)
464
(defun insert-fontified (window string beg end)
465
"set fonts in WINDOW for string with "
467
; (print (list beg end))
468
(insert-string-with-regexp
469
window string beg end
470
#u"\n([^\n]+)\n[.=_*-][.=*_-]+\n|\\*Note ([^:]+)::"
474
(funcall window :tag :add "possible_xref" "0.0" "end")
479
(defun section-header (win string lis &aux (i (car lis)))
480
(let ((mark 'insert))
481
(insert-string win string (match-beginning 0)
483
(funcall win :insert mark #u"\n")
484
(funcall win :tag :add
485
(cdr (assoc (aref string (f + (match-end i) 2))
492
"insert - " : (f - (match-end i) (f + (match-beginning i ) -1 ))
495
;;make index count be same..
496
(let ((n (f - (f - (match-end 0)
500
(funcall win :insert mark (make-string n )))
504
(defun insert-string (win string beg end)
506
(let ((ar (make-array (- end beg) :element-type 'string-char
507
:displaced-to string :displaced-index-offset beg)))
508
(funcall win :insert 'insert ar))))
510
(defun insert-string-with-regexp (win string beg end regexp reg-actions
512
(*window* win) *match-data*)
513
(declare (special *window* *match-data*))
514
(declare (fixnum beg end i))
515
(while (f >= (string-match regexp string beg end) 0)
518
(loop (or (< i 10) (return nil))
519
(cond ((f >= (match-beginning i) 0)
520
(setq temi (assoc i reg-actions))
524
((functionp (second temi))
525
(insert-string win string beg (match-beginning 0))
526
(funcall (second temi) win string temi))
527
((stringp (second temi))
528
(insert-string win string beg (match-end 0))
531
(funcall win :tag :add v
532
"insert -" : (f - (match-end 0) (match-beginning i)) : " chars"
533
"insert -" :(f - (match-end 0) (match-end i)): " chars"
537
(t (info-error "bad regexp prop")))
538
(setq beg (match-end 0))
539
(or (<= beg end) (error "hi"))
541
(insert-string win string beg end))
543
(defun count-char (ch string beg end &aux (count 0))
544
; "Count the occurrences of CH in STRING from BEG to END"
545
(declare (character ch))
546
(declare (string string))
547
(declare (fixnum beg end count))
549
(if (eql (aref string beg) ch) (incf count))
553
(defun start-of-ith-line (count string beg &optional (end -1))
554
(declare (string string))
555
(declare (fixnum beg end count))
556
(if (< end 0) (setq end (length string)))
557
(cond ((eql count 1) beg)
560
(if (eql (aref string beg) #\newline)
563
(if (<= count 0) (return-from start-of-ith-line beg)))
567
(defun index-to-position (index string beg &optional (end -1) &aux (count 0))
568
; "Find INDEX of form \"line.char\" in STRING with 0.0 at BEG and
569
; up to END. Result is a fixnum string index"
570
(declare (string string index))
571
(declare (fixnum beg end count))
572
(if (< end 0) (setq end (length string)))
573
(let* ((line (atoi index 0))
574
(charpos (atoi index (+ 1 (position #\. index)))))
575
(declare (fixnum line charpos))
576
(setq count (start-of-ith-line line string beg end))
577
(print (list count charpos))
582
;;; Local Variables: ***
584
;;; version-control:t ***
585
;;; comment-column:0 ***
586
;;; comment-start: ";;; " ***
added
removed
gcl-tk/tinfo.lsp
