;;; -*- Mode:LISP; Package:Zwei; Fonts:(CPTFONT); Base:10 -*-

;;; Copyright (C) Lisp Machine, Inc. 1984, 1985, 1986
;;;   See filename "Copyright" for
;;; licensing and release information.


;;; The routines responsible for retrieving and setting up nodes, and 
;;; managing Gateway's internal data structures, including history
;;; lists and automatically generated scripts. 


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                      ;;;
;;;                                                                      ;;;
;;;                       DATA MANAGEMENT ROUTINES                       ;;;
;;;                                                                      ;;;
;;;                                                                      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SEEK-DATA-NODE
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Takes a script frame, which can be obtained in a variety of ways, and
;;; displays the data node named in the frame in the context of the script
;;; node named in the frame.

(defun SEEK-DATA-NODE (script-frame &key backtrack &aux data-node-name
		       data-node script-node-name script-node
		       script-frame-to-display-from)
  
  ;;; If we've been handed something demonstrabably bogus
  ;;; (which of course could never happen) don't try to use it.
  
  (when (or (not script-frame) (not (typep script-frame 'array)))
    (barf "~% **** ERROR. CANNOT DISPLAY REQUESTED NODE. ****"))
  
  ;;; Perform the tests needed to validate the script frame.
  ;;; Note that if SCRIPT-NODE has been rebuilt by GET-NODE, 
  ;;; we will automatically be transferred to the new version 
  ;;; because SCRIPT-FRAME-TO-DISPLAY will have been drawn
  ;;; from it rather than from the old version.
  
  (setq data-node-name (script-frame-node-name script-frame)
	script-node-name (script-frame-script-name script-frame)
	data-node (get-node data-node-name 'complain 'throw)
	script-node (get-node script-node-name 'complain 'throw)
	script-frame-to-display-from
	  (get-script-frame-for-node data-node-name script-node-name))
  
  
  (unless script-frame-to-display-from
    (barf "~% **** ERROR. NODE: ~A ****~% **** NOT IN SCRIPT: ~A ****"
	  (btrim (string-upcase (caddr data-node-name)))
	  (btrim (string-upcase (caddr script-node-name)))))
  
  (gateway-display-node data-node script-frame-to-display-from :backtrack backtrack))
  


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; GET-NODE
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Takes a nodename, and finds, sets up, and returns the node.

;;; The arguments tell what to do if the node cannot be found:
;;; complain-or-quiet: 'complain   print an error message
;;;                    'quiet      don't print an error message
;;; throw-or-continue: 'throw      throw to the Zmacs command loop
;;;                    'continue   return normally to point of call

(defun GET-NODE (nodename complain-or-quiet throw-or-continue
		 &aux pathname node-id node buffer name-string node-sections)
  (setq nodename (standardize-nodename nodename))
  
  ;;; First check whether the node is already known (due to a prior call to get-node).
  ;;; If it is, return it immediately.
  (if (setq node (gethash nodename *node-hash-table*))
      node
    
    ;;;Otherwise, try to find the node. If it can't be found, take the actions specified
    ;;;in the arguments. If it can, set it up and put it in the hash table.
    
    (setq pathname (make-absolute-pathname (car nodename)))
    (setq node-id (string-upcase (btrim (cadr nodename))))
    
    ;;; Look for the file/buffer.
    (if (not (setq buffer (find-a-file-that-does-exist pathname)))
	(get-node-exception
	  (format nil "~% **** FILE NOT FOUND: ~A ****" (send pathname :string-for-printing))
	  complain-or-quiet
	  throw-or-continue)
      
      ;;; If the buffer needs resectionizing (due to editing) resectionize it.
      (when (gethash pathname *resectionize-p-hash-table*)
        (normalize-gateway-buffer buffer)
	(sectionize-file-buffer buffer)
	(puthash pathname nil *resectionize-p-hash-table*))
      
      ;;; Look for the node in the buffer.
      (dolist (sect (send buffer :inferiors))
	(setq name-string (send sect :name)) 
	(if (string-equal (substring name-string 0 (- (length name-string) 4)) node-id)
	    (setq node-sections (nconc node-sections (list sect)))
	  (when node-sections (return))))
      (if (not node-sections)
	  (get-node-exception
	    (format
	      nil "~% **** NODE NOT FOUND: ~A ****" (btrim (string-upcase (caddr nodename))))
	    complain-or-quiet
	    throw-or-continue)
	
        ;;;Set up the node and put it in the hash table, then return it.
	(setq node (make-node-from-node-sections nodename node-sections))
	(puthash nodename node *node-hash-table*)
	node))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; CHECK-NODE-NONEXISTENT
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; The inverse of get-node, for use when the need is to be sure that
;;; a node does NOT exist.

(defun CHECK-NODE-NONEXISTENT (nodename complain-or-quiet throw-or-continue)
  (when (get-node nodename 'quiet 'continue)
    (get-node-exception (format nil "~% ***** NODE ALREADY EXISTS *****")
			complain-or-quiet throw-or-continue)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; MAKE-NODE-FROM-NODE-SECTIONS
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Takes (from GET-NODE) a nodename and a list of the Zmacs sections that constitute the
;;; node. Creates a GNODE flavor instance and fills in all instance variables to reflect
;;; the node name and node sections.

;;; Script, Index, and Related Information data are converted into property lists, then 
;;; into the form they will have when actually used. The original purpose of this 
;;; indirection was to allow for the processing of nodes in various formats: conversion
;;; to a property list is done first, via whatever is the appropriate transform, after
;;; which Gateway can operate the same way irrespective of the original node syntax.
;;; Experience has shown that it would have been simpler to design a consistant 
;;; Gateway-internal format for each section type, and convert directly to that in the
;;; first place. Hence the property-list method is a historical artifact. Only converters
;;; for Gateway syntax currently exist.

(defun MAKE-NODE-FROM-NODE-SECTIONS
       (nodename node-sections &aux buffer scr ind rel fun node)
  
  (pkg-bind 'zwei
    (setq buffer (send (car node-sections) :superior))
    
    ;;; Walk the sections
    (dolist (section node-sections)
      
      ;;; Get each section's name and value.
      (let* ((section-title (send section :name))
	     (type-string (substring section-title (- (string-length section-title) 4)))
	     (contents
	       (string-remove-fonts
		 (string-interval (send section :first-bp) (send section :last-bp) t t))))
	(cond
	  
          ;;; Convert a script section to a property list. 
	  ((string-equal type-string ".scr")
	   (setq scr "(")
	   (do ((idx1 (string-search-char #/@ contents)
		      (string-search-char #/@ contents (1+ idx1)))
		(idx2))
	       ((equal idx1 nil) (setq scr (read-from-string (string-append scr ")"))))
	     (setq idx2 (string-search-char #/return contents idx1))
	     (multiple-value-bind
	       (script-pathname script-name)
		 (parse-script-reference (substring contents idx1 idx2) buffer)
	       (setq scr
		     (string-append
		       scr
		       (make-nodename script-pathname script-name))))))
	  
          ;;; Convert an index section to a property list.
	  ((string-equal type-string ".ind")
	   (setq ind "(")
	   (do ((idx1 (string-search-char #/@ contents)
		      (string-search-char #/@ contents (1+ idx1)))
		(idx2))
	       ((equal idx1 nil) (setq ind (read-from-string (string-append ind ")"))))
	     (setq idx2 (string-search-char #/return contents idx1))
	     (multiple-value-bind
	       (ignore index-element)
		 (parse-script-reference (substring contents idx1 idx2) buffer)
	       (setq ind
		     (string-append
		       ind
		       (string-append "(/"" (btrim index-element) "/")"))))))
	  
          ;;;Convert a related-information section to a property list.
	  ((string-equal type-string ".see")
	   (setq rel "(")
	   (do ((idx1 (string-search-char #/@ contents)
		      (string-search-char #/@ contents (1+ idx1)))
		(idx2))
	       ((equal idx1 nil) (setq rel (read-from-string (string-append rel  ")"))))
	     (setq idx2 (string-search-char #/return contents idx1))
	     (multiple-value-bind
	       (related-information-pathname related-information-nodename)
		 (parse-script-reference (substring contents idx1 idx2) buffer)
	       (setq rel
		     (string-append
		       rel
		       (make-nodename
			 related-information-pathname related-information-nodename))))))
	  
          ;;;Fill out the instance variable for a function section
	  ((string-equal type-string ".fun")
	   (setq fun
		 (read-from-string
		   (nth-value 1 (function-start (send section :defun-line)))))))))
    
    ;;; Create and fill in the gnode flavor instance.
    (setq node
	  (make-gnode
	    :nodename nodename
	    :related-information rel
	    :script scr
	    :index ind
	    :function fun
	    :sections node-sections))
    
    ;;; Build a displayable/selectable script item list from a script property list.
    (when (gnode-script node)
      (script-item-list-setup node))
    
    ;;; Build a displayable/selectable related-information
    ;;; item list from a related-information property list.
    (when (gnode-related-information node)
      (related-information-item-list-setup node))
    
    ;;; Index item-lists are set up on demand; the above should be too.
    
    node))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; GET-NODE-EXCEPTION
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Called by GET-NODE when its argument is a nonexistent node, or 
;;; check-node-nonexistent when its argument is an existing node, to take
;;; the exception-action specified in the call that produced the exception.

(defun GET-NODE-EXCEPTION (message complain-or-quiet throw-or-continue)
  (cond
    ((and (eq complain-or-quiet 'complain) (eq throw-or-continue 'throw))
     (barf message))
    ((and (eq complain-or-quiet 'quiet) (eq throw-or-continue 'continue))
     nil)
    ((and (eq complain-or-quiet 'complain) (eq throw-or-continue 'continue))
     (tv:beep)
     (format *query-io* message)
     nil)
    ((and (eq complain-or-quiet 'quiet) (eq throw-or-continue 'throw))
     (throw 'zwei-command-loop t))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; RELATED-INFORMATION-ITEM-LIST-SETUP
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Create a displayable/selectable related-information list from a 
;;; related-information property list.

(defun RELATED-INFORMATION-ITEM-LIST-SETUP (current-node &aux current-reference-frame)
  (let ((item-list nil))
    (do* ((reference (gnode-related-information current-node)(cdr reference))
	  (end (length reference)(1- end))
	  (first-time t nil))
	 ((equal end 0)
	  (alter-gnode current-node :related-information-item-list item-list)
	  t)
      (if first-time
	  (progn
	    (setq current-reference-frame (make-script-frame 
					    :node-name (car reference))
		  item-list (nconc item-list
				   (list
				     (list
				       "RELATED INFORMATION" 
				       :no-select nil
				       :font fonts:bigfnt)
				     (list
				       (caddr
					 (script-frame-node-name current-reference-frame))
				       :value current-reference-frame
				       :font fonts:cptfont)))))
	(setf (script-frame-next current-reference-frame)
	      (setq current-reference-frame
		    (make-script-frame :previous current-reference-frame
				       :node-name (car reference))))
	(nconc item-list
	       (list
		 (list
		   (caddr (script-frame-node-name current-reference-frame))
		   :value current-reference-frame
		   :font fonts:cptfont)))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; UPDATE-HISTORY-LISTS
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Update relevant history lists to include the node/script designated
;;; (as a script frame) in the argument.

(defun UPDATE-HISTORY-LISTS (script-frame &aux history-frame)
  (setq history-frame (create-history-frame-from-script-frame script-frame))
  (cond
    ((gnode-script (get-node (history-frame-node-name history-frame) 'complain 'throw))
     (setq *top-script-history-list*
	   (update-a-history-list *top-script-history-list* history-frame))
     (setq *top-full-history-list*
	   (update-a-history-list *top-full-history-list* history-frame))
     (when (edit-mode-p)
       (setq *top-editing-history-list*
	     (update-a-history-list *top-editing-history-list* history-frame))))
    (t
     (setq *top-data-node-history-list*
	   (update-a-history-list *top-data-node-history-list* history-frame))
     (setq *top-full-history-list*
	   (update-a-history-list *top-full-history-list* history-frame))
     (when (edit-mode-p)
       (setq *top-editing-history-list*
	     (update-a-history-list *top-editing-history-list* history-frame))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; UPDATE-A-HISTORY-LIST
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Update a particular history list (first argument) to include a
;;; history frame (second argument.

(defun UPDATE-A-HISTORY-LIST (history-list history-frame &aux top-frame)
  (if (and (>= (length history-list) 2)
           (setq top-frame (caddr (cadr history-list)))
	   (equal (history-frame-node-name history-frame)
		  (history-frame-node-name top-frame))
	   (equal (history-frame-script-name history-frame)
		  (history-frame-script-name top-frame)))
      history-list
    (let ((item-list-header (car history-list))
	  (item-list (cdr history-list)))
      (setq item-list
	    (nconc 
	      (list item-list-header
		    (list
		      (cadr (history-frame-node-name history-frame))
		      :value history-frame
		      :font fonts:hl12))
	      item-list)))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; UPDATE-BACKTRACK-LIST
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Update the backtrack list to include a history frame.

(defun UPDATE-BACKTRACK-LIST (script-frame &aux history-frame top-frame)
  (setq history-frame (create-history-frame-from-script-frame script-frame))
  (unless (and (>= (length *backtrack-list*) 1)
	       (setq top-frame (caddar *backtrack-list*))
	       (equal (history-frame-node-name history-frame)
		      (history-frame-node-name top-frame))
	       (equal (history-frame-script-name history-frame)
		      (history-frame-script-name top-frame)))
    (let ((new-item
	    (list
	      (cadr (history-frame-node-name history-frame))
	      :value history-frame
	      :font fonts:hl12)))
      (push new-item *backtrack-list*))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; REDISPLAY-FULL-HISTORY-PANE
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Redisplay the current script pane so as to reflect the previous node and script.

(defun REDISPLAY-FULL-HISTORY-PANE (&aux (frame-item-list (list nil)))

  (let ((first-entry (third (second *top-full-history-list*)))
	(second-entry (third (third *top-full-history-list*)))
	(third-entry (third (fourth *top-full-history-list*)))
	(fourth-entry (third (fifth *top-full-history-list*))))
    
    (setq frame-item-list
	  (nconc frame-item-list
		 (list
		   (list "FULL HISTORY"
			 :value
			 (ncons #/hyper-super-f)
			 :font fonts:hl12b
			 :documentation
			 " DISPLAY A LIST OF ALL PREVIOUSLY SELECTED DATA AND SCRIPT NODES."
			 ))))

    (if first-entry
	(setq frame-item-list
	      (nconc frame-item-list
		     (list
		       (list (btrim (caddr (history-frame-node-name first-entry)))
			     :value
			     (ncons #/roman-i)
			     :font fonts:hl12
			     :documentation "SELECT THIS ITEM FROM THE FULL HISTORY"))))
      (setq frame-item-list
	    (nconc frame-item-list
		   (list
		     (list "" :no-select nil)))))

    (if second-entry
	(setq frame-item-list
	      (nconc frame-item-list
		     (list
		       (list (btrim (caddr (history-frame-node-name second-entry)))
			     :value
			     (ncons #/roman-ii)
			     :font fonts:hl12
			     :documentation "SELECT THIS ITEM FROM THE FULL HISTORY"))))
      (setq frame-item-list
	    (nconc frame-item-list
		   (list
		     (list "" :no-select nil)))))
    
    (if third-entry
	(setq frame-item-list
	      (nconc frame-item-list
		     (list
		       (list (btrim (caddr (history-frame-node-name third-entry)))
			     :value
			     (ncons #/roman-iii)
			     :font fonts:hl12
			     :documentation "SELECT THIS ITEM FROM THE FULL HISTORY"))))
      (setq frame-item-list
	    (nconc frame-item-list
		   (list
		     (list "" :no-select nil)))))

    (if fourth-entry
	(setq frame-item-list
	      (nconc frame-item-list
		     (list
		       (list (btrim (caddr (history-frame-node-name fourth-entry)))
			     :value
			     (ncons #/roman-iv)
			     :font fonts:hl12
			     :documentation "SELECT THIS ITEM FROM THE FULL HISTORY"))))
      (setq frame-item-list
	    (nconc frame-item-list
		   (list
		     (list "" :no-select nil))))))  

  (send *full-history-pane* :set-item-list
	frame-item-list))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; REDISPLAY-CURRENT-SCRIPT-PANE
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Redisplay the current script pane so as to reflect the current node and script.

(defun REDISPLAY-CURRENT-SCRIPT-PANE (&aux frame-item-list)
  (setq frame-item-list (list nil))
  (setq frame-item-list
	(nconc frame-item-list
	       (list
		 (list "CURRENT SCRIPT"
		       :value
		       (ncons #/super-s)
		       :font fonts:hl12b
		       :documentation
		       " DISPLAY THE CURRENT SCRIPT." ))))    
  
  (if (script-frame-previous *current-script-frame*)
      (setq frame-item-list
	    (nconc frame-item-list
		   (list
		     (list
		       (btrim (caddr (script-frame-node-name
				       (script-frame-previous *current-script-frame*))))
		       :value
		       (ncons #/super-p)
		       :font fonts:hl12
		       :documentation "SELECT THIS ITEM FROM THE CURRENT SCRIPT"))))
    (setq frame-item-list
	  (nconc frame-item-list
		 (list
		   (list
		     ""
		     :no-select nil)))))
  (setq frame-item-list
	(nconc frame-item-list
	       (list
		 (list
		   (btrim (caddr (script-frame-node-name *current-script-frame*)))
		   :value
		   (ncons #/super-=)
		   :font fonts:hl12b
		   :documentation "SELECT THIS ITEM FROM THE CURRENT SCRIPT"))))
  (when (script-frame-next *current-script-frame*)
    (setq frame-item-list
	  (nconc frame-item-list
		 (list
		   (list
		     (btrim (caddr (script-frame-node-name
				     (script-frame-next *current-script-frame*))))
		     :value
		     (ncons #/super-n)
		     :font fonts:hl12
		     :documentation "SELECT THIS ITEM FROM THE CURRENT SCRIPT")))))
  (when (and (script-frame-next *current-script-frame*)
	     (script-frame-next (script-frame-next *current-script-frame*)))
    (setq frame-item-list
	  (nconc frame-item-list
		 (list
		   (list
		     (btrim (caddr (script-frame-node-name
				     (script-frame-next
				       (script-frame-next *current-script-frame*)))))
		     :value
		     (ncons #/hyper-super-hand-down)
		     :font fonts:hl12
		     :documentation "SELECT THIS ITEM FROM THE CURRENT SCRIPT")))))
  (send *current-script-pane* :set-item-list frame-item-list))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; HIGHLIGHT-CURRENT-SCRIPT
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Put into boldface the name of the current node in the item-list that is
;;; displayed when the current-script command is selected.

(defun HIGHLIGHT-CURRENT-SCRIPT (&aux item-list)
  (setq item-list
	(cdr (gnode-script-item-list
	       (get-node
		 (script-frame-script-name *current-script-frame*) 'complain 'throw))))
  (dolist (item item-list)
    (if (equal (third item) *current-script-frame*)
	(setf (fifth item) fonts:cptfontb)
      (setf (fifth item) fonts:cptfont))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SCRIPT-ITEM-LIST-SETUP
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Create a displayable/selectable script item list from a script property list.
;;; Create the list of script frames that will embody the script.

(defun SCRIPT-ITEM-LIST-SETUP (script &aux script-name current-script-frame)
  (setq script-name (gnode-nodename script))
  (let ((item-list nil))
    (do* ((new-script (gnode-script script)(cdr new-script))
	  (end (length new-script)(1- end))
	  (first-time t nil))
	 
	 ((equal end 0)
	  (alter-gnode script :script-item-list item-list)
	  t)
      (if first-time
	  (progn
	    (setq current-script-frame (make-script-frame 
					 :script-name script-name
					 :node-name (car new-script))
		  item-list
		  (nconc item-list
			 (list
			   (list (caddr script-name)
				 :no-select nil
				 :font fonts:bigfnt)
			   (list (caddr (script-frame-node-name current-script-frame))
				 :value current-script-frame
				 :font fonts:cptfont))))
	    (alter-gnode script :first-script-frame current-script-frame))
	(setf (script-frame-next current-script-frame)
	      (setq current-script-frame
		    (make-script-frame :script-name script-name
				       :previous current-script-frame
				       :node-name (car new-script))))
	(nconc item-list
	       (list
		 (list (caddr (script-frame-node-name current-script-frame))
		       :value current-script-frame
		       :font fonts:cptfont)))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; GET-SCRIPT-FRAME-FOR-HISTORY-FRAME
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Map a history frame back to the script frame (if any) that currently
;;; corresponds to it. The "currently" is significant because arbitrary
;;; changes to the data may have been made via editing since the history frame 
;;; was created.

(defun GET-SCRIPT-FRAME-FOR-HISTORY-FRAME (history-frame)
  (get-script-frame-for-node
    (history-frame-node-name history-frame)
    (history-frame-script-name history-frame)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; GET-SCRIPT-FRAME-FOR-NODE
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Search the script frames associated with a script looking for one that
;;; references a particular node. Return the frame if it is found, or nil.

(defun GET-SCRIPT-FRAME-FOR-NODE
       (sought-nodename script-to-search
	&aux car-sought-nodename cadr-sought-nodename caddr-sought-nodename
	candidate-nodename candidate-script-frame)
  (setq car-sought-nodename (make-absolute-pathname (car sought-nodename)))
  (setq cadr-sought-nodename (btrim (cadr sought-nodename)))
  (setq caddr-sought-nodename (btrim (caddr sought-nodename)))
  (dolist (script-frame-item
	    (gnode-script-item-list (get-node script-to-search 'complain 'throw)))
    (if (and (setq candidate-script-frame (caddr script-frame-item))
	     (setq candidate-nodename (script-frame-node-name candidate-script-frame))
	     (eq car-sought-nodename
		 (make-absolute-pathname (car candidate-nodename)))
	     (string-equal
	       cadr-sought-nodename
	       (btrim (cadr candidate-nodename)))
	     (string-equal
	       caddr-sought-nodename
	       (btrim (caddr candidate-nodename))))
	(return candidate-script-frame))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SELECT-FROM-SCRIPT
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Display a node whose name was selected by mousing from a script (internal command).

(defun SELECT-FROM-SCRIPT (&aux selected-line nodename script-frame)
  (tv:with-mouse-grabbed
    (turn-gateway-mouse-handling-off)
    (setq selected-line (get-source-script-line (nth-value 3 (mouse-char *window*))))
    (if (or (not selected-line)
	    (string-equal selected-line ""))
	(set-gateway-mouse-handling)
      (multiple-value-bind (script-pathname script-name)
	  (parse-script-reference selected-line)
	(setq nodename (read-from-string (make-nodename script-pathname script-name))))
      (if (string-equal (car nodename) "NIL")
	  (set-gateway-mouse-handling)
	(if (not (get-node nodename 'complain 'continue))
	    (set-gateway-mouse-handling)
	  (setq script-frame
		(get-script-frame-for-node
		  nodename (script-frame-node-name *current-script-frame*)))
	  (if (not script-frame)
	      (set-gateway-mouse-handling)
	    (seek-data-node script-frame)))))))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; GET-SOURCE-SCRIPT-LINE
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Maps a formatted line in the *SCRIPT-DISPLAY-BUFFER* to the unformatted line
;;; in the source script from which it was derived, and returns that line.
;;; The method is to count lines from the tops of the two buffers: the nth line
;;; in the unformatted buffer corresponds to the nth line in the formatted
;;; buffer.

(defun GET-SOURCE-SCRIPT-LINE (line)
  (do
    ((display-line
       (bp-line (send *script-display-buffer* :first-bp))
       (line-next display-line))
     (real-line
       (line-next (send *script-source-section* :defun-line))
       (line-next real-line))
     (last-line (bp-line (send *script-display-buffer* :last-bp)))
     (success-flag)
     (done-flag))
    (done-flag
      (return (and success-flag (line-previous real-line))))
    (cond-every
      ((eq display-line line)
       (setq success-flag t)
       (setq done-flag t))
      ((eq display-line last-line)
       (setq done-flag t)))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SELECT-VIA-REFERENCE
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Display a node whose name was selected by mousing a symbol or cross reference.

(defun SELECT-VIA-REFERENCE (&aux ref type)
  (tv:with-mouse-grabbed
    (turn-gateway-mouse-handling-off)
    (multiple-value (ref type) (ref-under-mouse *window*))
    (when (stringp ref) (setq ref (btrim ref)))
    (cond ((null ref)
	   (set-gateway-mouse-handling))
	  ((eq type :node)
           (select-via-cross-reference ref))
	  ((eq type :symbol)
           (select-via-symbol ref))
	  (t (set-gateway-mouse-handling)))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SELECT-VIA-CROSS-REFERENCE
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Display a node whose name was selected by mousing a cross-reference.

(defun SELECT-VIA-CROSS-REFERENCE
       (ref &aux node-from-ref script-from-ref) 

  ;Evade the inconsistant processing of slashes by zapping them.
  (do ((i 0 (1+ i)))
      ((equal i (1- (string-length ref))))
    (when (char-equal (aref ref i) #//)
      (setq ref (string-append (substring ref 0 i) (substring ref (1+ i))))))

  (setq node-from-ref
	(if (string-equal (substring ref 0 1) "(")
	    ref
	  (string-append
	    "(" (send (send *current-gateway-buffer* :pathname) :name) ")" ref)))

  (setq script-from-ref (gethash node-from-ref *node-script-hash-table*))

  (unless script-from-ref  
    (set-gateway-mouse-handling)
    (barf (format nil "~% **** NODE NOT FOUND: ~A ****" (string-upcase ref))))

  (finish-selection-via-reference node-from-ref script-from-ref))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SELECT-VIA-SYMBOL
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Display a node whose name was selected by mousing a symbol.

(defun SELECT-VIA-SYMBOL
       (ref &aux translated-ref node-from-ref script-from-ref)

  (setq translated-ref (get (doc-symbol ref) :odm-node))

  (unless translated-ref  
    (set-gateway-mouse-handling)
    (barf (format nil "~% **** SYMBOL NOT FOUND: ~A ****" (string-upcase ref))))

  (setq node-from-ref (car translated-ref))
  (setq script-from-ref (cdr translated-ref))

  (finish-selection-via-reference node-from-ref script-from-ref)
  (put-reference-at-top ref))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; FINISH-SELECTION-VIA-REFERENCE
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Finish displaying a node whose name was selected by mousing a symbol 
;;; or cross reference.

(defun FINISH-SELECTION-VIA-REFERENCE (node-from-ref script-from-ref
				       &aux nodename scriptname script-frame)
  (multiple-value-bind (node-file node-id)
      (parse-script-reference node-from-ref)
    (setq nodename (read-from-string (make-nodename node-file node-id))))
  (multiple-value-bind (script-file script-id)
      (parse-script-reference script-from-ref)
    (setq scriptname (read-from-string (make-nodename script-file script-id))))
  (if (or (string-equal (car nodename) "NIL")
	  (string-equal (car scriptname) "NIL")
	  (not (get-node nodename 'complain 'continue))
	  (not (get-node scriptname 'complain 'continue)))
      (set-gateway-mouse-handling)
    (setq script-frame (get-script-frame-for-node nodename scriptname))
    (if (not script-frame)
	(set-gateway-mouse-handling)
      (seek-data-node script-frame))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; PUT-REFERENCE-AT-TOP
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; When a node was selected by mousing a symbol, put the documentation of the
;;; symbol at the top of the screen.

(defun put-reference-at-top
       (ref &aux (point (point)) car-point (ref-length (string-length ref)) last-line)
  (block nil
    (com-goto-beginning)
    (setq last-line (car (send *interval* :last-bp)))
    (tagbody search-for-reference

	(setq car-point (car point))

	(when (and ( (string-length car-point) ref-length)
		   (not (and (> (string-length car-point) ref-length)
			     (not (char-equal (aref car-point ref-length) #/ ))))
		   (= (ldb %%ch-font (aref car-point 0)) 3)
		   (string-equal ref (substring car-point 0 ref-length)))
          (recenter-window *window* :start (point))
	  (return nil))

	(when (eq car-point last-line)
	  (com-goto-beginning)
	  (barf (format nil "~% **** SYMBOL NOT FOUND: ~A ****" (string-upcase ref))))
	
	(com-down-real-line)
	(com-beginning-of-line)
	(go search-for-reference))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; DOC-SYMBOL
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Convert a string to a symbol.

(defun DOC-SYMBOL (token &key (start 0) (end (string-length token)) &aux colon-position)
  (ignore-errors
    (if (not (setq colon-position (string-search-char #\: token start end)))
	(intern-soft (string-upcase (string-remove-fonts (substring token start end))))
      (let ((package (string-remove-fonts (substring token start colon-position)))
	    (name (string-remove-fonts (substring token (1+ colon-position) end))))
	(intern-soft (string-upcase name) (pkg-find-package (nstring-upcase package)))))))