;;; -*- Scheme -*-
;; Copyright (c) 1992 Massachusetts Institute of Technology
-;;
+;;
;; This material was developed by the Scheme project at the Massachusetts
;; Institute of Technology, Department of Electrical Engineering and
;; Computer Science. Permission to copy this software, to redistribute
;; it, and to use it for any purpose is granted, subject to the following
;; restrictions and understandings.
-;;
+;;
;; 1. Any copy made of this software must include this copyright notice
;; in full.
-;;
+;;
;; 2. Users of this software agree to make their best efforts (a) to
;; return to the MIT Scheme project any improvements or extensions that
;; they make, so that these may be included in future releases; and (b)
;; to inform MIT of noteworthy uses of this software.
-;;
+;;
;; 3. All materials developed as a consequence of the use of this
;; software shall duly acknowledge such use, in accordance with the usual
;; standards of acknowledging credit in academic research.
-;;
+;;
;; 4. MIT has made no warrantee or representation that the operation of
;; this software will be error-free, and MIT is under no obligation to
;; provide any services, by way of maintenance, update, or otherwise.
-;;
+;;
;; 5. In conjunction with products arising from the use of this material,
;; there shall be no use of the name of the Massachusetts Institute of
;; Technology nor of any adaptation thereof in any advertising,
;;;
;;; Author: Brian A. LaMacchia -- bal@zurich.ai.mit.edu
;;;
-;;; $Id: techinfo.scm,v 1.3 1992/11/12 18:00:43 cph Exp $
+;;; $Id: techinfo.scm,v 1.4 1993/08/10 07:11:47 cph Exp $
;;;
-(define-variable techinfo-web-buffer
+(declare (usual-integrations))
+\f
+(define-variable techinfo-web-buffer
"Buffer which contains a copy of the TechInfo web file."
false)
-(define-variable techinfo-buffer
+(define-variable techinfo-buffer
"Buffer used for displaying TechInfo information."
false)
-(define-variable techinfo-current-node-list
+(define-variable techinfo-current-node-list
"Cached list of web file information for the current node."
false)
-(define-variable techinfo-attached-filesystems
+(define-variable techinfo-attached-filesystems
"List of filesystems already attached by this run of TechInfo.
If a filesystem name appears in this list subsequent calls to
attach will not be made."
'())
-(define-variable techinfo-parent-list
+(define-variable techinfo-parent-list
"List of parent nodes from this node to the root node."
false)
-(define-variable techinfo-history-list
+(define-variable techinfo-history-list
"List of TechInfo nodes previously visited."
'("0"))
-(define-variable techinfo-need-to-attach-afs
+(define-variable techinfo-need-to-attach-afs
"True if AFS is not available by default, and the NFS->AFS
translator on Atalanta is needed. At Tech Square this variable
is set to t. At Athena it is nil."
(buffer-end web-buffer))))
(extract-string (line-start the-mark 0) (line-end the-mark 0)))))
-;;; Takes one arg, STRING, which is a line from the TechInfo web file.
-;;; Parses the line and returns a list of the information contained.
-;;; Usually the result of (techinfo-find-line n) is passed directly to
+;;; Takes one arg, STRING, which is a line from the TechInfo web file.
+;;; Parses the line and returns a list of the information contained.
+;;; Usually the result of (techinfo-find-line n) is passed directly to
;;; this function.
(define (techinfo-parse-line string)
(define (techinfo-internal-parse string char)
(let ((next-index
(substring-find-next-char string start end char)))
(if next-index
- (loop (1+ next-index) end (cons (substring string start next-index) the-list))
+ (loop (1+ next-index)
+ end
+ (cons (substring string start next-index) the-list))
(cons (string-tail string start) the-list)))))
(let ((the-list-1 (techinfo-internal-parse string #\:)))
- (reverse
+ (reverse
(cons
(reverse (techinfo-internal-parse (car the-list-1) #\,))
(cons
(reverse (techinfo-internal-parse (cadr the-list-1) #\,))
(cddr the-list-1))))))
-
+\f
(define (techinfo-line/number techinfo-line)
(list-ref techinfo-line 0))
(let ((foo (member (cadr (ref-variable techinfo-history-list))
(techinfo-line/children-list node-list))))
(if foo
- (techinfo-display-internal-node
- node-list
- (1+ (- (length (techinfo-line/children-list node-list)) (length foo))))
+ (techinfo-display-internal-node
+ node-list
+ (1+ (- (length (techinfo-line/children-list node-list))
+ (length foo))))
(techinfo-display-internal-node node-list)))
(techinfo-display-leaf-node node-list))))
-
+\f
(define (techinfo-insert-node-header node-list)
- (let ((siblings (techinfo-line/children-list
- (techinfo-parse-line (techinfo-find-line
- (car (ref-variable techinfo-parent-list)))))))
- (let ((rest (member (techinfo-line/number
- (ref-variable techinfo-current-node-list)) siblings)))
+ (let ((siblings
+ (techinfo-line/children-list
+ (techinfo-parse-line (techinfo-find-line
+ (car (ref-variable techinfo-parent-list)))))))
+ (let ((rest
+ (member (techinfo-line/number
+ (ref-variable techinfo-current-node-list)) siblings)))
(if rest
(let* ((num (- (length siblings) (length rest)))
(prev (-1+ num))
(next (1+ num))
(left-string
(if (>= prev 0)
- (string-append
- "Prev: "
- (techinfo-line/title (techinfo-parse-line
- (techinfo-find-line (list-ref siblings prev)))))
+ (string-append
+ "Prev: "
+ (techinfo-line/title
+ (techinfo-parse-line
+ (techinfo-find-line (list-ref siblings prev)))))
"Prev: (none)"))
(right-string
(if (< next (length siblings))
(string-append
- "Next: "
- (techinfo-line/title (techinfo-parse-line
- (techinfo-find-line (list-ref siblings next)))))
+ "Next: "
+ (techinfo-line/title
+ (techinfo-parse-line
+ (techinfo-find-line (list-ref siblings next)))))
"Next: (none)")))
- (let ((padding (- (ref-variable fill-column) (string-length right-string))))
+ (let ((padding
+ (- (ref-variable fill-column)
+ (string-length right-string))))
(insert-string
(if (> padding (+ 10 (string-length left-string)))
(string-pad-right left-string padding)
(insert-string
(string-append
" " (string-pad-left (number->string the-index) 5) " "
- (techinfo-line/title (techinfo-parse-line (techinfo-find-line this-child)))
+ (techinfo-line/title
+ (techinfo-parse-line (techinfo-find-line this-child)))
"\n"))
(if (= the-index placement-index)
(set! point (line-start (current-point) -1)))
(loop (cdr the-children) (1+ the-index) (car the-children))))))
(set-buffer-read-only! (current-buffer))
(set-current-point! point)))
-
+\f
(define (techinfo-display-leaf-node node-list)
(set-variable! techinfo-current-node-list node-list)
(set-buffer-writable! (current-buffer))
(the-filename (techinfo-line/filename node-list)))
(if (not (member the-filesys (ref-variable techinfo-attached-filesystems)))
(begin
- (if (and (string=? the-filesys "afs") (ref-variable techinfo-need-to-attach-afs))
- (run-synchronous-process false false (->pathname "/usr/local/bin") false
- "attach" "-n" "-m" "/afs" "-e" "atalanta.mit.edu:/afs")
- (run-synchronous-process false false (->pathname "/usr/local/bin") false
+ (if (and (string=? the-filesys "afs")
+ (ref-variable techinfo-need-to-attach-afs))
+ (run-synchronous-process false false
+ (->pathname "/usr/local/bin") false
+ "attach" "-n" "-m" "/afs" "-e"
+ "atalanta.mit.edu:/afs")
+ (run-synchronous-process false false
+ (->pathname "/usr/local/bin") false
"attach" "-n" the-filesys))
(set-variable! techinfo-attached-filesystems
- (cons the-filesys (ref-variable techinfo-attached-filesystems)))))
+ (cons the-filesys
+ (ref-variable techinfo-attached-filesystems)))))
(if (file-exists? the-filename)
(insert-file (current-point) the-filename))
(set-current-point! (buffer-start (current-buffer)))))
(define (techinfo-space-DWIM-internal-node)
(let ((point (current-point)))
- (let ((the-match (re-match-forward "[ ]*\\([0-9][0-9]*\\)"
- (line-start point 0) (line-end point 0))))
+ (let ((the-match (re-match-forward "[ ]*\\([0-9][0-9]*\\)"
+ (line-start point 0)
+ (line-end point 0))))
(if the-match
(let ((num (string->number
(extract-string (re-match-start 1) (re-match-end 1)))))
(define (techinfo-initialize)
(if (not (member "ti_data" (ref-variable techinfo-attached-filesystems)))
(begin
- (run-synchronous-process false false (->pathname "/usr/local/bin") false
- "attach" "-n" "ti_data")
+ (run-synchronous-process false false (->pathname "/usr/local/bin")
+ false "attach" "-n" "ti_data")
(set-variable! techinfo-attached-filesystems
- (cons "ti_data" (ref-variable techinfo-attached-filesystems)))))
+ (cons "ti_data"
+ (ref-variable techinfo-attached-filesystems)))))
(set-variable! techinfo-web-buffer (find-buffer "*techinfo-web*"))
(if (not (ref-variable techinfo-web-buffer))
(let ((the-buf (create-buffer "*techinfo-web*")))
(set-current-major-mode! (ref-mode-object techinfo))
(set-variable! techinfo-parent-list '("0"))
(techinfo-display-node "0"))
-
+\f
(define-major-mode techinfo read-only "TechInfo"
"Major mode for viewing information in the TechInfo database.
In an internal node:
(lambda ()
(techinfo-initialize)))
-(define-command techinfo-space
- "In an internal node, move to the subnode whose title is on the
+(define-command techinfo-space
+ "In an internal node, move to the subnode whose title is on the
same line as point. In a leaf node, scroll-up."
'()
(lambda ()
- (if (string=? (techinfo-line/filesystem (ref-variable techinfo-current-node-list)) "")
+ (if (string=? (techinfo-line/filesystem
+ (ref-variable techinfo-current-node-list))
+ "")
(techinfo-space-DWIM-internal-node)
(techinfo-space-DWIM-leaf-node))))
In a leaf node, scroll-down."
'()
(lambda ()
- (if (string=? (techinfo-line/filesystem (ref-variable techinfo-current-node-list)) "")
+ (if (string=? (techinfo-line/filesystem
+ (ref-variable techinfo-current-node-list))
+ "")
(techinfo-delete-DWIM-internal-node)
(techinfo-delete-DWIM-leaf-node))))
(lambda ()
(let ((parent (car (ref-variable techinfo-parent-list))))
(if (not (null? (cdr (ref-variable techinfo-parent-list))))
- (set-variable! techinfo-parent-list
+ (set-variable! techinfo-parent-list
(cdr (ref-variable techinfo-parent-list))))
(techinfo-display-node parent))))
(lambda ()
(set-variable! techinfo-parent-list '("0"))
(techinfo-display-node "0")))
-
+\f
(define-command techinfo-goto-node
- "Go to the NTH node listed as a child of the current node.
+ "Go to the NTH node listed as a child of the current node.
NTH is an integer between 1 and the number of children of the current node.
When called interactively, NTH may be provided either as a prefix arg,
or the user will be prompted for a value."
"NItem number: "
(lambda (num)
- (let ((new-node (list-ref (techinfo-line/children-list
+ (let ((new-node (list-ref (techinfo-line/children-list
(ref-variable techinfo-current-node-list))
(-1+ num))))
(if new-node
(begin
(set-variable! techinfo-parent-list
- (cons (techinfo-line/number
+ (cons (techinfo-line/number
(ref-variable techinfo-current-node-list) )
(ref-variable techinfo-parent-list)))
(techinfo-display-node new-node))))))
Do nothing if no such sibling exists."
'()
(lambda ()
- (let ((siblings (techinfo-line/children-list
- (techinfo-parse-line (techinfo-find-line
- (car (ref-variable techinfo-parent-list)))))))
- (let ((rest (member (techinfo-line/number
- (ref-variable techinfo-current-node-list)) siblings)))
+ (let ((siblings
+ (techinfo-line/children-list
+ (techinfo-parse-line
+ (techinfo-find-line
+ (car (ref-variable techinfo-parent-list)))))))
+ (let ((rest (member (techinfo-line/number
+ (ref-variable techinfo-current-node-list))
+ siblings)))
(if (and rest (cdr rest))
(techinfo-display-node (car (cdr rest))))))))
Do nothing if no such subling exists."
'()
(lambda ()
- (let ((siblings (techinfo-line/children-list
- (techinfo-parse-line (techinfo-find-line
- (car (ref-variable techinfo-parent-list)))))))
- (let ((rest (member (techinfo-line/number
- (ref-variable techinfo-current-node-list)) siblings)))
- (if rest
+ (let ((siblings
+ (techinfo-line/children-list
+ (techinfo-parse-line
+ (techinfo-find-line
+ (car (ref-variable techinfo-parent-list)))))))
+ (let ((rest (member (techinfo-line/number
+ (ref-variable techinfo-current-node-list))
+ siblings)))
+ (if rest
(let ((num (- (length siblings) (length rest))))
(techinfo-display-node (list-ref siblings (-1+ num)))))))))
(select-buffer (other-buffer (current-buffer)))))
(define-command techinfo-last
- "Go to the node visited immediately before this node.
-WARNING: Calling this function causes the parent information to
+ "Go to the node visited immediately before this node.
+WARNING: Calling this function causes the parent information to
no longer be valid."
'()
(lambda ()
(if (and (not (null? (ref-variable techinfo-history-list)))
(not (null? (cdr (ref-variable techinfo-history-list)))))
(let ((new-node (car (cdr (ref-variable techinfo-history-list)))))
- (set-variable! techinfo-history-list (cdr (ref-variable techinfo-history-list)))
+ (set-variable! techinfo-history-list
+ (cdr (ref-variable techinfo-history-list)))
(techinfo-display-node new-node)
- (set-variable! techinfo-history-list (cdr (ref-variable techinfo-history-list)))))))
-
-;; Edwin Variables:
-;; scheme-environment: '(edwin)
-;; scheme-syntax-table: (access edwin-syntax-table (->environment '(edwin)))
-;; End:
+ (set-variable! techinfo-history-list
+ (cdr (ref-variable techinfo-history-list)))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff