;;; -*- Mode: Common-Lisp; Package: GLOSS; Base: 10; Fonts: COURIER,HL12B,HL12BI -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1985, Texas Instruments Incorporated. All rights reserved.
;;; Copyright (c) 1984, Texas Instruments Incorporated.  All Rights Reserved.
;;; Copyright (C) 1986, Texas Instruments Incorporated. All rights reserved.
	 

(DEFFLAVOR glossary-entry
        ((name "")
         (text-list nil)               ;each line in the text-list is of the format:
                                       ;(<text-string> <ref1> <ref2> ... <refn>)
                                       ;<ref> :== (<start index> <end index> <xref entry object>)
         (x-references nil)                     
         (glossary nil))
        ()
  :settable-instance-variables
  (:documentation :special-purpose
   "These are entries in the glossary.
The NAME is the string that is being defined.
The TEXT-LIST is a list of lists, the CAR of each sublist is one
text line in the definition of NAME.
X-REFERENCES is the list of glossary-entry objects that are referred to by the TEXT-LIST.
For example:
 NAME = \"Current Stack Group -\"
 TEXT-LIST =
\((\"                The stack group  associated  with  the  current  computation\")
\(\"                being  performed  by the LISP machine.  (also called running\"(41. 44. #<GLOSSARY-ENTRY 20704144>))
\(\"                stack group)\")
\(\"\"))
 X-REFERENCES = (#<GLOSSARY-ENTRY 20704144>) ")
 )

(DEFMETHOD (glossary-entry :PRINT-SELF) (STREAM &REST IGNORE)
  "Includes the name of the glossary entry in it's printed representation:
#<GLOSSARY-ENTRY Current Stack Group - 20704144>."
  (SI:PRINTING-RANDOM-OBJECT (SELF STREAM :TYPEP)
    (PRINC (SEND self :name) stream)))

(DEFMETHOD (glossary-entry :after :init) (ignore)
  "Change the format of text-list from a list of strings to a list of lists.
This format is needed for storage of cross-referencing inforamation.
The cross-reference information (if any) is stored in the CDR of the sublists.
E.g. (<string1> <string2> ...) ==> ((<string1>) (<string2>) ...)"
  (SETQ text-list
        (LOOP for line in text-list
              collect (IF (STRINGP line)        ;Only change things if not already a list.
                          (CONS line nil)
                          line)))) 

(DEFMETHOD (glossary-entry :entry-menu-item) ()
  "Returns a menu entry for this glossary entry.
Format is (<display string (name)> :value <this entry object> :documentation <doc>)"
  (make-menu-item
    :display-string name
    :value self
    :DOCUMENTATION (FORMAT nil "Click Any Mouse Button to select: ~A." name))
  )


(DEFMETHOD (glossary-entry :generate-x-references) ()
  "Generate all possible cross-references for the text of this entry."
  (SETQ x-references nil)    ;Start out without any x-references
  ;; Convert the multi-line text of this entry into one long string (TEXT-STRING)
  (LET ((text-string (APPLY #'STRING-APPEND
                                    (LOOP for text-line in text-list
                                          collect (STRING-APPEND
						    (STRING-TRIM '(#\SPACE)
								 (text-line-string text-line))
                                                                 #\space)))))
    (DECLARE (STRING text-string))
    ;; Remove multiple spaces that were put in by PDWS for filler.
    (LOOP for pos = (SEARCH "  " text-string :TEST #'CHAR-EQUAL)
          until (NULL pos)
          DO
          (SETQ text-string (STRING-APPEND (SUBSEQ text-string 0 pos)
                                           (SUBSEQ text-string (1+ pos)))))
    ;; Search for the name of each entry in the glossary in TEXT-STRING
    ;; Add references to the instance variable X-REFERENCES.
    (LOOP for entry in (SEND glossary :entry-list)
          UNLESS (OR (EQ entry self)            ;Don't cross-reference yourself
                     (MEMBER entry x-references :TEST #'EQ)) ;Don't add it twice to the list
          DO
          (IF (SEARCH (STRING-APPEND " " (SEND entry :name)) ;Space guarantees a full word
                             text-string :TEST #'CHAR-EQUAL)
              (PUSH-END entry x-references))
          )
    ;;; Empty the list of x-references
    (LOOP for line in text-list
	  DO
	  (SETF (text-line-xref-list line) nil))
    ;;; Now we have the X-REFERENCES (list of entries).  Put them on the text-line that they belong.
    (LOOP for x-ref in x-references
          for x-ref-name = (SEND x-ref :name)
          for x-ref-found = nil
          DO
          (LOOP for line in text-list
		DO
		(MULTIPLE-VALUE-BIND (position xref-length)
		    (position-of-glossary-entry  x-ref-name (text-line-string line))
		  (WHEN (NOT (NULL position))
		    (PUSH (make-xref :start-index position
				     :end-index (1- (+ position xref-length))
				     :entry-object x-ref)
			  (text-line-xref-list line))
		    (SETF x-ref-found t)))
		

                finally (RETURN x-ref-found)))
    ;;; Get rid of conflicts (two entries overlapping)
    (LOOP for line in text-list
          for occupied-list = nil
          for ref-list = (text-line-xref-list line)
          WHEN (> (LENGTH ref-list) 1)
          DO
	  ;;The following orders the xref list from left to right.
	  ;;This is required to correctly print the text (and xrefs out to the screen)
          (SETQ ref-list (SORT ref-list	     
                               #'(lambda (x y) (< (xref-start-index x)
						  (xref-start-index y)))))
          (LET ((delete-list nil))
            (LOOP for ref in ref-list
                  UNLESS (MEMBER ref delete-list :TEST #'EQ) ;Don't bother if ref is deleted
                  DO
                  (LOOP for sub-ref in ref-list ;Check if sub-ref should be deleted
                        WHEN (AND (NOT (MEMBER sub-ref delete-list :TEST #'EQ))	   ;Don't delete twice
                                  (NEQ ref sub-ref)     ;Don't delete yourself
                                  ;; They overlap
                                  (OR (<= (xref-start-index ref)
					  (xref-start-index sub-ref)
					  (xref-end-index ref))
                                      (<= (xref-start-index sub-ref)
					  (xref-start-index ref)
					  (xref-end-index sub-ref)))
                                  ;; Sub-ref is smaller than ref
                                  (<= (- (xref-end-index sub-ref)
					 (xref-start-index sub-ref))
                                      (- (xref-end-index ref) (xref-start-index ref))))
                        DO
                        (PUSH sub-ref delete-list))
                  finally (RETURN delete-list))
            (DOLIST (ref delete-list)
              (SETQ ref-list (DELETE ref ref-list :TEST #'EQ))))
          ;; Store new xref list
	  (SETF (text-line-xref-list line) ref-list)
          )
    ))

(DEFMETHOD (glossary-entry :delete-x-references) ()
  "Deletes all of the cross references for this glossary entry."
  (LOOP for line in text-list
	DO
	(SETF (text-line-xref-list line) nil))
  (SETF x-references nil))

(DEFMETHOD (glossary-entry :write-cgloss-self) (stream)
  "Writes a cgloss version of this entry to the STREAM."
  (LET-GLOBALLY ((*PRINT-BASE* 10.)
                 (*READ-BASE* 10.)
                 (*nopoint nil))
    (FORMAT stream "~%(~S  (" name)
    (LOOP for text in text-list
          DO
          (FORMAT stream "~%~5T(~S~{~S~})"
                  (text-line-string text)
                  (LOOP for ref in (text-line-xref-list text)
                        collect (LIST (xref-start-index ref)
                                      (xref-end-index ref)
                                      (SEND (xref-entry-object ref) :name)))))
    
    (FORMAT stream "))")))

(DEFMETHOD (glossary-entry :write-formatted-self) (STREAM)
  "Writes a :TEXT format version of this glossary entry to the stream.
This format is the same format that TI uses for hardcopy versions of the glossary."
  (FORMAT STREAM "~2%~V@T~A" (SEND glossary :entry-column) name)
  (LOOP for text in text-list
	DO
	(FORMAT STREAM "~%~A" (text-line-string text)))
  )

(DEFMETHOD (glossary-entry :convert-xref-strings-to-pointers) ()
  "After reading the compiled entries from a file, cross-references must be changed from
strings (names of the entry) to objects."
  (SETF x-references nil)                       ;To begin with
  (LOOP for line in text-list
        DO
        (LOOP for ref in (text-line-xref-list line)
              for ref-name = (xref-entry-object ref) ;Really a string which must be converted to an object
              for ref-object = (LOOP for entry in (SEND glossary :entry-list)
                                     WHEN (STRING-EQUAL ref-name (SEND entry :name))
                                     RETURN entry
                                     finally
				     (RETURN (PROGN (tv:notify nil "The entry, ~S, was not found" ref-name)
                                                            ref-name)))
              DO
              (PUSH-END ref-object x-references)
	      (SETF (xref-entry-object ref) ref-object)
              )
        ))


(DEFMETHOD (glossary-entry :string-for-printing) ()
  "This is used by functions like STRING."
  name)

;;;
;;; UTILITY FUNCTIONS FOR GLOSSARY-ENTRY
;;; 

(DEFUN position-of-glossary-entry (entry-name line-of-text)
  "Searches the LINE-OF-TEXT for the ENTRY-NAME, taking into account any
possible extra spaces that were thrown in for filler.  The starting position of
ENTRY-NAME and the length of ENTRY-NAME in the LINE-OF-TEXT are
returned.  The length could be longer than the length of the ENTRY-NAME
if there are spaces used for padding.
This function is really an extension of STRING-SEARCH."
  (DECLARE (VALUES start-position length-of-found-name))
  (LET ((name-list (sentence-to-list-of-words entry-name))
	(word-list (sentence-to-list-of-words line-of-text))
	start-pos start-loc end-pos length)
    (SETQ start-pos (find-sequence-in-list name-list word-list))
    (WHEN (NOT (NULL start-pos))
      
      (SETQ start-loc (position-of-nth-word start-pos line-of-text))
      (SETQ end-pos (+ (position-of-nth-word (+ start-pos (LENGTH name-list) -1) line-of-text)
		       (LENGTH (FIRST (LAST name-list)))))
      (SETQ length (- end-pos start-loc))
      )
    (VALUES start-loc length))
  )

(DEFUN find-sequence-in-list (target-list source-list)
  "Searches the SOURCE-LIST for a sequence of elements that
are EQUALP to the elements of TARGET-LIST..
If the TARGET-LIST is not found, NIL is returned."
  (DECLARE (VALUES position-in-source-list-or-nil))
  (WHEN (NOT (NULL target-list))	   ;A TARGET-LIST of NIL returns NIL
    (LOOP for word-list on source-list
	  for location from 0 
	  for found-p = (sequence-in-list-p target-list word-list)
	  WHEN found-p RETURN location
	  )))

(DEFUN sequence-in-list-p (target-list word-list)
  "Predicate to check whether the CAR of WORD-LIST is the start
of an sequence that is EQUALP to the elements in TARGET-LIST."
  (DECLARE (VALUES (t-or-nil)))
  (COND ((NULL target-list) t)
	((NULL word-list) nil)
	(t (AND (IF (AND (STRINGP (FIRST word-list))
			 (NULL (CDR target-list)))
		    ;; Only allow suffixes on the last word of a multi-word glossary-entry name.
		    (gloss-equal-words-p (FIRST target-list) (FIRST word-list))
		    (EQUALP (FIRST target-list) (FIRST word-list)))
		(sequence-in-list-p (CDR target-list) (CDR word-list))))))

(DEFUN gloss-equal-words-p (target source)
  "Predicate that checks whether the two strings are
equal for the purpose of referring to the same word in the Glossary.
If the strings aren't equalp, this function will still return T if
the SOURCE has a valid suffix appended at its end."
  (DECLARE (VALUES t-or-nil))
  (OR (STRING-EQUAL target source)
      (AND (> (LENGTH source) (LENGTH target))
	   (STRING-EQUAL target (SUBSEQ source 0 (LENGTH target)))
	   (legal-suffix-p (SUBSEQ source 0 (LENGTH target))
			   (SUBSEQ source (LENGTH target))))))

(DEFUN legal-suffix-p (root suffix)
  "Predicate that checks whether SUFFIX is an acceptable suffix for
ROOT in respect to a glossary entry name."
  (DECLARE (VALUES t-or-nil))
  root					   ;Ignored for now
  ;; The list of legal suffixes is hard-coded for now.
  ;; Ideally, we should care about what ROOT is.
  (OR (NOT (NULL (MEMBER suffix '("ed" "d" "s" "es" "ing" "er" "ly") :TEST #'STRING-EQUAL)))
      (AND (NOT (ZEROP (LENGTH suffix)))
	   (EQUALP (AREF suffix 0) #\-))))    ;For things like "-based"

(DEFPARAMETER *glossary-whitespace-characters* '(#\SPACE #\. #\, #\; #\( #\))
  "Characters that are treated as whitespace in text.")

(DEFUN position-of-nth-word (n words)
  "Given a string of words, the starting position within the string (WORDS)
is returned..   There is no error checking.  N should not be greater than the number
of words in WORDS."
  (DECLARE (VALUES starting-position-in-words))
  (LOOP with pos = (STRING-SEARCH-NOT-SET *glossary-whitespace-characters*
					 words)	   ;Get to the start of the first character
	for spaces from 0 to (1- n)
	DO
	(SETQ pos (STRING-SEARCH-NOT-SET *glossary-whitespace-characters*
					 words
					 (STRING-SEARCH-SET *glossary-whitespace-characters* words pos)))
	finally (RETURN pos)))

(DEFUN sentence-to-list-of-words (sentence)
  "Given SENTENCE, a string of words and spaces, a list of each word
is returned (w/o any spaces)."
  (DECLARE (VALUES list-of-words))
  (LOOP for remaining-string first (STRING-TRIM *glossary-whitespace-characters* sentence)
	then (STRING-TRIM *glossary-whitespace-characters* remaining-string) 
	with word-list = nil
	until (equalp (STRING-TRIM *glossary-whitespace-characters* remaining-string) "")
	for next-word = (STRING-TRIM
			  *glossary-whitespace-characters*
			  (SUBSEQ remaining-string
				     0
				     (STRING-SEARCH-SET *glossary-whitespace-characters* remaining-string)))
	DO
	(SETQ remaining-string (SUBSEQ remaining-string
					  (LENGTH next-word)))
	(PUSH-END next-word word-list)
	finally (RETURN word-list)))  



(DEFUN string-with-double-spaces-removed (input-string)
  "Removes all double spaces from INPUT-STRING and returns the altered
string.  Function is non-destructive."
  (DECLARE (STRING INPUT-STRING))
  (LOOP with output-string = input-string
	for pos = (SEARCH "  " (the string output-string) :TEST #'CHAR-EQUAL)
	until (NULL pos)
	DO
	(SETQ output-string (STRING-APPEND (SUBSEQ output-string 0 pos)
					 (SUBSEQ output-string (1+ pos))))
	finally (RETURN output-string))) 



(DEFFLAVOR glossary
        ((entry-list nil)
         (entry-menu-item-list nil)
         (sort-p t)			   ;whether the glossary menu should be sorted
         (loaded-files nil)		   ;The files that were loaded to construct the glossary (pathname objects)
         (entry-column *entry-name-left-margin*)   ;The column that the glossary entries begin in the input file(s).
	 (name "Unnamed Glossary")	   ;Name of the glossary
	 (file-to-load nil)		   ;The file to load to create this glossary
         (entries-changed-p nil))	   ;If the entry-list has been changed since entry-menu-item-list was built.
        ()
  (:settable-instance-variables entry-list sort-p)
  (:gettable-instance-variables entry-column name loaded-files)
  :inittable-instance-variables
  (:init-keywords :load-file-p)
  (:documentation :special-purpose
   "This object is a glossary that can be used by the glossary system.
ENTRY-LIST is a list of glossary-entry objects, strings with definitions.
ENTRY-MENU-ITEM-LIST is the list of items that is used to construct the entry menu.
This item list is reconstructed each time that the ENTRY-LIST is changed.")
  )

(DEFMETHOD (glossary :after :init) (init-plist)
  "Load glossary entries if there are none."
  (IF (AND (NULL entry-list)
	   file-to-load
	   (GET init-plist :load-file-p))
      (SEND self :load-appropriate-file)))

(DEFMETHOD (glossary :load-appropriate-file) ()
  "Loads the FILE-TO-LOAD if it can.  If there is an error, that error condition is returned."
  (DECLARE (VALUES t-or-error-condition))
  (IF (NOT (SEND self :entries-p))
      (CONDITION-CASE (condition)
	  (LET* ((lookup-pathname (fs:parse-pathname (SEND self :file-to-load)))
		 (file-type (SEND lookup-pathname :canonical-type))
		 (file-format (LOOP for format in (glossary-formats-in-decreasing-priority)
				    WHEN (EQUALP file-type (SEND format :file-type))
				    RETURN format
				    finally (RETURN nil))))
	    (COND ((NOT (NULL file-format))
		   (SEND self (SEND file-format :glossary-read-method) lookup-pathname))
		  ((NULL file-type)
		   (LOOP for format in (glossary-formats-in-decreasing-priority)
			 WHEN (SEND format :load-if-exists lookup-pathname self)
			 RETURN t))	   ;Stop searching since we just found (and loaded a file)
		  )
	    self
	    )
	(ERROR
	 condition)
	(t self))
    self))

(DEFMETHOD (glossary :PRINT-SELF) (STREAM &REST IGNORE)
  "Includes the name of the glossary  in it's printed representation."
  (SI:PRINTING-RANDOM-OBJECT (SELF STREAM :TYPEP)
    (PRINC (SEND self :name) stream)))


(DEFMETHOD (glossary :around :describe) (cont mt message)
  "This makes a describe of a glossary instance more readable by limiting
the length of the printed lists of instance variables.
Otherwise, a 500 element list would be printed on the screen."
  (LET ((*PRINT-LENGTH* 6))
    (FUNCALL-WITH-MAPPING-TABLE cont mt message)))


(DEFMETHOD (glossary :file-to-load) ()
  "Returns the file-to-load and ensures that the returned value is
a pathname object."
  (IF (INSTANCEP file-to-load)
      file-to-load
      (fs:parse-pathname file-to-load nil *default-pathname*)))

(DEFMETHOD (glossary :add-entry) (entry-name &optional text-list)
  "Add a glossary-entry to this glossary."
  (DECLARE (VALUES glossary-entry-object))
  (SETQ entries-changed-p t)
  (UNLESS (TYPEP entry-name 'glossary-entry)	   ;Check if name is already a glossary-entry object
    (SETQ entry-name (MAKE-INSTANCE 'glossary-entry :name entry-name
                              :text-list text-list :glossary self)))
  (PUSH-END entry-name entry-list)		   ;Add this entry to ENTRY-LIST
  entry-name)

(DEFMETHOD (glossary :remove-entry) (entry-object)
  "Removes a glossary entry from this glossary."
  (WHEN (TYPEP entry-object 'glossary-entry)
    (SETQ entries-changed-p t)
    (PUSH entry-object *deleted-glossary-entries*)
    (SETQ entry-list (DELETE entry-object entry-list :TEST #'EQ))))  


(DEFMETHOD (glossary :lookup-entry) (entry-name)
  "ENTRY-NAME is either the name of a prospective glossary entry or the actual entry object.
The glossary-entry object corresponding to ENTRY-NAME (or NIL) is returned."
  (DECLARE (VALUES glossary-entry-or-nil))
  (LOOP for entry in entry-list ;Look for the entry
	WHEN (STRING-EQUAL (SEND entry :name) entry-name)
	RETURN entry
	finally (RETURN nil)))

(DEFMETHOD (glossary :clear) ()
  "Clear all entries from the glossary."
  (SETQ entries-changed-p t
        entry-list nil
        loaded-files nil))

(DEFMETHOD (glossary :entries-p) ()
  "Are there any entries in the glossary???"
  (NOT (NULL entry-list)))

(DEFMETHOD (glossary :entry-start-p) (line)
  "non-NIL if LINE is the start of a new glossary entry (an entry name)"
  (NOT (OR (< (LENGTH line) entry-column)
           (= (AREF line entry-column) #\space)))) 

(DEFMETHOD (glossary :entry-menu-item-list) ()
  "Returns the menu item list of glossary entries.
If the entry list hasn't changed, ENTRY-MENU-ITEM-LIST is returned.
Otherwise a new list is built and assinged to ENTRY-MENU-ITEM-LIST."
;  (WHEN (OR entries-changed-p
;            (NULL entry-menu-item-list))
;    (SETQ entry-menu-item-list (LOOP for entry in entry-list
;                                     collect (SEND entry :entry-menu-item))))
  (WHEN (AND sort-p entries-changed-p)
    (SETQ entry-list
          (SORT entry-list #'(lambda (x y)
			       (g-string-lessp (tv:menu-item-string x)
					       (tv:menu-item-string y))))) 
    (SETQ entries-changed-p nil
	  entry-menu-item-list entry-list))
  entry-menu-item-list)


(DEFSUBST real-entry-name (line)
  "Returns the real entry name for the entry, devoid of extra spaces and
parenthesized words."
  (DECLARE (STRING line))
  (LET* ((new-line (STRING-TRIM '(#\sp) line))
	 (open-pos (SEARCH "(" new-line :TEST #'CHAR-EQUAL))
	 (close-pos (IF open-pos (SEARCH ")" new-line :TEST #'CHAR-EQUAL))))
    (DECLARE (STRING new-line))
    (IF (AND (NOT (NULL open-pos))
	     (NOT (NULL close-pos))
	     (< open-pos close-pos))
	(SETQ new-line (STRING-TRIM '(#\sp)
				    (STRING-APPEND (SUBSEQ new-line 0 open-pos)
						   (SUBSEQ new-line (1+ close-pos))))))
    new-line))  

(DEFMETHOD (glossary :load-text-file) (&optional (filename *default-pathname*))
  "This does the actual work of loading a file of glossary entries into this glossary."
  (SETQ filename (fs:merge-pathname-defaults filename *default-pathname* :Text))
  ;; Read the entire file into LINE-LIST
  (LET ((line-list (WITH-OPEN-FILE (file filename :direction :input)
                     (PUSH (SEND file :pathname) loaded-files)	     ;Record the where the glossary entries came from
                     (LOOP for line = (MULTIPLE-VALUE-BIND (STRING eof)	     ;Hack to do what
					  (READ-LINE file nil :eof nil nil)  ;readline used to do
					(IF (EQ eof :eof) eof STRING))
                           until (EQ line :eof)
                           collect line))))
    ;; This takes care of the page breaks and underlining (characters in column 1)
    (WHEN (NULL line-list)
          (tv:notify nil "Entry list undefined in ~A. ~%The current glossary is undefined." filename))
    (LOOP for line-number from 1 to (LENGTH line-list)
          for line = (NTH (1- line-number) line-list)
          for first-char = (IF (ZEROP (LENGTH line))
                               #\space
                               (AREF line 0))
          with delete-list = nil
          WHEN (NEQ first-char #\space)
          DO 
          (CASE first-char
            (#\+ ;; Underlining
             (PUSH line-number delete-list))
            (#\1 ;; A page break (7 lines deleted)
             (LOOP for number from (- line-number 3) to (+ line-number 3)
                   DO
                   (IF (<= 1 number (LENGTH line-list))
                       (PUSH number delete-list))))
            (T nil))
          finally (LOOP for number in delete-list
                        DO
                        (DELETE (NTH (1- number) line-list)
                              line-list :TEST #'EQ)))
    ;; Now read the entries and add them to the glossary
    (LOOP for previous-line first "XXXX" then line ;Used to prevent sequences of more than 1 blank line
	  for line in line-list
          with first-entry-p = T
          with entry-name = "" AND entry-text-list = nil
	  unless (AND (EQUALP previous-line "")	   ;Multiple blank line prevention
		      (EQUALP line ""))
          DO
          (COND ((SEND self :entry-start-p line)
                 (IF first-entry-p
                     (SETQ first-entry-p nil)
                     (SEND self :add-entry entry-name entry-text-list))
                 (SETQ entry-name (real-entry-name line))
                 (SETQ entry-text-list nil))
                (T
                 (PUSH-END line entry-text-list)))
	  finally (SEND self :add-entry entry-name `(,@entry-text-list ""))))
  self) 


(DEFMETHOD (glossary :generate-x-references) ()
  "Loop through the entries, generating x-references for each. (SLOW!!!!) "
  (LOOP for entry in entry-list
        DO
        (SEND entry :generate-x-references)))



(DEFMETHOD (glossary :write-cgloss-file) (&optional (filename  *default-pathname*))
  "Format of the entries in the file is:
   (<name-string> (<text-string1> (<start1> <end1> <ref-name1>) ...) ...)"
  (SETQ filename (fs:merge-pathname-defaults filename *default-pathname* :CGloss))
  (WITH-OPEN-FILE (stream filename :direction :output)
    (LOOP for entry in entry-list
          DO
          (SEND entry :write-cgloss-self stream))))

(DEFMETHOD (glossary :write-text-file) (&optional (filename  *default-pathname*))
  "Writes a standard TEXT style file of the selected glossary."
  (SETQ filename (fs:merge-pathname-defaults filename *default-pathname* :text))
  (WITH-OPEN-FILE (stream filename :direction :output)
    (LOOP for entry in entry-list
          DO
          (SEND entry :write-formatted-self stream))))

(DEFMETHOD (glossary :write-binary-file) (&optional (filename  *default-pathname*))
  "Write the glossary as a binary file."
  (LET ((*print-base* 10.))
    (SETQ filename (fs:merge-pathname-defaults filename *default-pathname* nil nil))
    (DUMP-FORMS-TO-FILE filename (SEND self :forms-for-writing-glossary) '(:package :gloss :base 10.))
    ))

(DEFMETHOD (GLOSSARY :write-lisp-file) (&optional (filename  *default-pathname*))
  "Write the glossary as a lisp file."
  (LET ((*print-base* 10.))
    (SETQ filename (fs:merge-pathname-defaults filename *default-pathname* nil nil))
    (WITH-OPEN-FILE (file filename :direction :output)
      (FORMAT file ";;; -*- Mode: Common-Lisp; Package: GLOSS; Base: 10 -*-~3%")
      (LOOP for form in (SEND self :forms-for-writing-glossary)
	    DO
	    (GRIND-TOP-LEVEL form 80 file)
	    (TERPRI file) (TERPRI file)))))

(DEFMETHOD (GLOSSARY :forms-for-writing-glossary) ()
  "Returns the list of forms to write to a glossary file."
  (LET ((form-to-write nil)
	(version-declaration		   ;Put a declaration of what version of binary file we are using
					   ;Future glossary binary files may be in a different format
	  `(SETQ binary-format-version 1.))
	(clause-list (LOOP for entry in entry-list
			   collect (LIST
				     (SEND entry :name)
				     (LOOP for text in (SEND entry :text-list)
					   collect (CONS
						     (text-line-string text)
						     (LOOP for ref in (text-line-xref-list text)
							   collect (LIST
								     (xref-start-index ref)
								     (xref-end-index ref)
								     (SEND (xref-entry-object ref) :name))))))))
	)
    (SETQ form-to-write `(SETQ temporary-glossary-entry-list ',clause-list))
    (LIST version-declaration form-to-write)))

(DEFMETHOD (glossary :write-file) (&optional file-format-name
				   (filename  *default-pathname*))
  "Writes all of the glossary entries to a file, format is determined from FILE-FORMAT."
  (DECLARE (SPECIAL *most-preferred-file-format* *glossary-file-formats*)) ;Declared below
  (WHEN (NULL file-format-name)		   ;Only if user didn't specify a format
    (IF (TYPEP *most-preferred-file-format* 'glossary-file-format)
	(SETF file-format-name (SEND *most-preferred-file-format* :name))
      (SETF file-format-name :binary)))
  (LET ((gloss-file-format (LOOP for format in *glossary-file-formats*
				 WHEN (EQ file-format-name (SEND format :name))
				 RETURN format
				 finally (RETURN nil))))   ;If File-format was not found
    (WHEN gloss-file-format
      (SETQ filename (fs:merge-pathname-defaults filename *default-pathname*
						 (SEND gloss-file-format :file-type)))
      (CASE (SEND gloss-file-format :name)
	;;Handle special cases first
	(:binary (SEND self :write-binary-file filename))
	(:lisp   (SEND self :write-lisp-file filename))
	(otherwise
	 (WITH-OPEN-FILE (stream filename :direction :output)
	   (LOOP for entry in entry-list
		 DO
		 (SEND entry (SEND gloss-file-format :entry-write-method) stream))))))))



(DEFMETHOD (glossary :load-cgloss-file) (&optional (filename *default-pathname*))
  "Loads a cgloss glossary file."
  (LET-GLOBALLY ((*PRINT-BASE* 10.)
                 (*READ-BASE* 10.)
                 (*nopoint nil))
    (SETQ filename (fs:merge-pathname-defaults filename *default-pathname* :CGloss))
    (LET ((new-list (WITH-OPEN-FILE (file filename :direction :input)
                      (PUSH (SEND file :pathname) loaded-files)     ;Record where entries came from
                      (LOOP for line = (READ file nil :eof)
                            until (EQ line :eof)
                            collect line))))
      (WHEN (NULL new-list)
        (tv:notify nil "Entry list undefined in ~A.~%The current glossary is empty." filename))
      (SEND self :add-glossary-entry-list new-list))))   

(DEFMETHOD (glossary :load-lisp-file) (&optional (filename *default-pathname*))
  "Loads a binary glossary file into this glossary."
  (DECLARE (SPECIAL temporary-glossary-entry-list ;Temporary variable to which entry list is assigned
		    binary-format-version))	   ;This may change (from 1) if the format of the file changes
  (SETQ filename (fs:merge-pathname-defaults filename *default-pathname* nil nil))
  (SETQ binary-format-version nil)
  (SETQ temporary-glossary-entry-list nil)
  (LOAD filename :verbose nil :print nil)
  (IF (NULL temporary-glossary-entry-list)
    (tv:notify nil "Entry list undefined in ~A.~%The current glossary is empty." filename)
    (CASE binary-format-version
      (1. (SEND self :add-glossary-entry-list temporary-glossary-entry-list))
      (t (tv:notify nil "The version of the binary glossary file (~A) is unknown."  binary-format-version))
    ))) 

(DEFMETHOD (glossary :add-glossary-entry-list) (new-list)
  "Adds all of the glossary entries in NEW-LIST to the glossary.
This is used by CGloss and binary format glossary files."
  (LOOP for entry in new-list 
	for entry-name = (FIRST entry)
	for text-list = (SECOND entry)
	DO
	(SEND self :add-entry entry-name text-list))
  (LOOP for entry in entry-list
	DO
	(SEND entry :convert-xref-strings-to-pointers)))

(DEFMETHOD (glossary :merge-in-glossary) (other-glossary)
  "Merges in OTHER-GLOSSARY to this glossary.
This is done by putting the entries of OTHER-GLOSSARY in this glossary (not by copying)."
  (SETQ entry-list (NCONC entry-list (SEND other-glossary :entry-list)))
  (SETQ loaded-files (NCONC loaded-files (SEND other-glossary :loaded-files)))
  (SETQ entries-changed-p t) ;Indicate that the entry menu must be resorted/recreated
  (LOOP for entry in (SEND other-glossary :entry-list)	     ;This entry belongs to this glossary now.
	DO (SEND entry :set-glossary self))
  )




(DEFUN define-glossary (name-string file-to-load &key load-immediately-p make-current-glossary-p)
  "Defines a new glossary called NAME-STRING.
When the file of glossary entries needs to be loaded, FILE-TO-LOAD will be loaded.
If LOAD-IMMEDIATELY-P is non-NIL, an attempt will be made to load the glossary
immediately (as it is defined).  Otherwise, it won't be loaded until it is first selected
within the Glossary utility.
If MAKE-CURRENT-GLOSSARY-P is non-NIL, it will be made the currently selected glossary."
  (DECLARE (VALUES new-glossary-object))
  (DECLARE (SPECIAL *list-of-glossaries* *glossary* *entry-pane* *glossary-frame* *command-pane*))
  (LET ((glossary (MAKE-INSTANCE 'glossary
				 :name name-string
				 :file-to-load file-to-load
				 :load-file-p load-immediately-p)))
    (PUSH glossary *list-of-glossaries*)
    (WHEN make-current-glossary-p
      (SETQ *glossary* glossary)	   ;Make this glossary current
      (WHEN (NOT (NULL *entry-pane*))	   ;If we have windows
	(SEND *entry-pane* :set-item-list (SEND *glossary* :entry-menu-item-list)))
      (WHEN (NOT (NULL *glossary-frame*))
	(SEND *glossary-frame* :set-label (glossary-system-label)))	   ;Update the window label
      )
    (WHEN (NOT (NULL *command-pane*))
      (SEND *command-pane* :set-item-list (command-menu-item-list)))	   ;Update command pane
    glossary
    ))

(export 'define-glossary)

;;;
;;; GLOSSARY FILE FORMATS
;;; 


(DEFFLAVOR glossary-file-format
	   (name			   ;Name of the file-format (a keyword)
	    file-type			   ;The type of file to use for this glossary-file-type (eg., :TEXT)
	    entry-write-method		   ;Method used to write a glossary entry to a stream
	    glossary-read-method	   ;Method used to read glossary entries from a file
	    documentation-string
	    priority			   ;Desirability of loading this file-format (Range: 1-10)
	    )
	   ()
  :settable-instance-variables
  (:documentation :special-purpose
		  "Instances of this flavor are created for each new glossary file format."))

(DEFMETHOD (glossary-file-format :print-self) (STREAM &rest IGNORE)
  "Includes the name of the file format in it's printed representation"
  (si:printing-random-object (self STREAM :typep)
    (PRINC (SEND self :name) STREAM)))

(DEFMETHOD (glossary-file-format :load-if-exists) (defaults &optional glossary)
  "Checks to see if a file of the specified format exists.
If there is such a file, it is loaded and filename is returned.
Otherwise, NIL is returned."

  (DECLARE (SPECIAL *glossary*))
  (WHEN (NULL GLOSSARY)
    (SETQ GLOSSARY *glossary*))
  (LET ((filename (MAKE-PATHNAME :defaults defaults
				    :type file-type)))
    (WHEN (PROBE-FILE filename)
      (SEND glossary glossary-read-method filename)
      filename
      ))) 
  

(DEFPARAMETER *glossary-file-formats* nil
  "List of all of the glossary file-formats.  Each element is an instance of GLOSSARY-FILE-FORMAT.") 

(DEFVAR *most-preferred-file-format* nil
  "The instance of GLOSSARY-FILE-FORMAT that is fastest to load. (maximum priority value).")

(DEFUN define-glossary-file-format (name file-type entry-write-method glossary-read-method 
				 &optional (priority 5) documentation-string)
  "Defines a new glossary file-format."
  (LET ((gloss-format (MAKE-INSTANCE 'glossary-file-format
				   :name name
				   :file-type file-type
				   :entry-write-method entry-write-method
				   :glossary-read-method glossary-read-method
				   :priority priority
				   :documentation-string documentation-string))
	(duplicate-format (LOOP for format in *glossary-file-formats*
				WHEN (EQUALP (SEND format :send-if-handles :name) name)
				RETURN format
				finally (RETURN nil))))
    ;; Remove any pre-existing format of the same format
    (SETQ *glossary-file-formats* (DELETE duplicate-format *glossary-file-formats* :TEST #'EQ))
    ;; Update the record of the most preferred file format
    (WHEN (OR (NULL *most-preferred-file-format*)
	      (>= priority (SEND *most-preferred-file-format* :priority)))	   ;New format is preferred if =
      (SETQ *most-preferred-file-format* gloss-format))
    ;; Add this format to the list of defined file formats for the glossary.
    (PUSH gloss-format *glossary-file-formats*)
    gloss-format))

(EXPORT 'DEFINE-GLOSSARY-FILE-FORMAT)  

(DEFUN glossary-formats-in-decreasing-priority ()
  "Sorts the format list in order of increasing priority."
  (SETQ *glossary-file-formats* (SORT *glossary-file-formats*
				      #'(lambda (x y) (> (SEND x :priority) (SEND y :priority))))))

(define-glossary-file-format :text :text :write-formatted-self :load-text-file 2
			  "This is a simple text format as you would find in a manual.")

(define-glossary-file-format :cgloss :cgloss :write-cgloss-self :load-cgloss-file 5
			  "This is a Lisp format which includes Cross References as strings.")

(define-glossary-file-format :lisp :lisp nil :load-lisp-file 6
			  "This is a Lisp format which includes Cross References as strings.")

(define-glossary-file-format :binary (si:local-binary-file-type) nil :load-lisp-file 8
			     "Binary format.  This is quicker to load than the text formats.")

;;;
;;; IMPORTANT GLOBAL VARIABLES
;;; 

(DEFPARAMETER *GLOSSARY* nil
;	  (LET ((default-cons-area *glossary-area*))
;	    (MAKE-INSTANCE 'glossary
;			   :name "Main Glossary"
;			   :file-to-load *default-pathname*
;			   :load-file-p t))
  "The current glossary object.") 

(DEFPARAMETER *list-of-glossaries* nil
  "The list of glossaries that the system knows about.")

(DEFVAR *deleted-glossaries* nil
  "The list of glossaries that have been deleted from the system.")



(COMPILE-FLAVOR-METHODS glossary-entry glossary)



;;;
;;; General utility functions
;;; 

(DEFUN main-glossary ()
  "Returns the main glossary object (else NIL)."
  (DECLARE (VALUES glossary-object-or-nil))
  (LOOP for glossary in *list-of-glossaries*
	when (STRING-EQUAL (SEND glossary :name) "Main Glossary")
	return glossary))


(DEFUN delete-xrefs-on-nth-line (entry-name line-number)
  "Removes all cross references on the specified line-number
in the glossary entry named entry-name."
  (DECLARE (VALUES ignore))
  (LET ((entry (SEND (main-glossary) :lookup-entry entry-name)))
    (SETF (text-line-xref-list (NTH (1- line-number)
				    (SEND entry :text-list)))
	  nil)))