summaryrefslogtreecommitdiff
path: root/Build/source/utils/xindy-new/xindy/src/index.lsp
diff options
context:
space:
mode:
Diffstat (limited to 'Build/source/utils/xindy-new/xindy/src/index.lsp')
-rw-r--r--Build/source/utils/xindy-new/xindy/src/index.lsp1333
1 files changed, 1333 insertions, 0 deletions
diff --git a/Build/source/utils/xindy-new/xindy/src/index.lsp b/Build/source/utils/xindy-new/xindy/src/index.lsp
new file mode 100644
index 00000000000..7d171f96fab
--- /dev/null
+++ b/Build/source/utils/xindy-new/xindy/src/index.lsp
@@ -0,0 +1,1333 @@
+;; line 835 "index.nw"
+;; $Id: index.nw,v 1.31 1997/03/26 16:18:37 kehr Exp $
+
+(lisp:defpackage "INDEX")
+(lisp:in-package "INDEX")
+(lisp:provide "index")
+
+#+CLISP (lisp:require "base")
+#+CLISP (lisp:require "locref")
+#+CLISP (lisp:require "idxstyle")
+#+CLISP (lisp:require "ordrules")
+
+(eval-when (compile load eval)
+ (lisp:use-package "CLOS")
+ #+(and :XP CLISP) (lisp:use-package "XP")
+ #-CLISP (lisp:require "base")
+ #-CLISP (lisp:require "locref")
+ #-CLISP (lisp:require "idxstyle")
+ (lisp:use-package "BASE")
+ (lisp:use-package "LOCREF")
+ (lisp:use-package "IDXSTYLE"))
+
+;; The following construct must be separated since the definition of
+;; the *feature* :ORDRULES was added via loading the package
+;; "idxstyle" but is only active *after* reading the whole SEXP.
+
+(eval-when (compile load eval)
+ #+:ORDRULES (use-package "ORDRULES"))
+
+;; line 986 "idxentry.nw"
+;; $Id: idxentry.nw,v 1.29 1997/03/27 17:17:25 kehr Exp $
+
+;; line 1002 "idxentry.nw"
+(defvar *number-of-indexentries*)
+(defvar *current-number*)
+;; line 1007 "idxentry.nw"
+(defvar *percentage-list*)
+(defvar *processing-percentage-list*)
+
+(defun print-rest-of-percentages (plist)
+ (dolist (percent plist)
+ (when (<= (cdr percent) 100)
+ (print-percent percent))))
+
+(defun print-percent (percent-cons)
+ (info " [~A%]" (cdr percent-cons)))
+;; line 85 "idxentry.nw"
+(defclass index-entry ()
+ ((main-key :initarg :main-key)
+ (merge-key :initarg :merge-key)
+ (sort-key :initarg :sort-key)
+ (print-key :initarg :print-key)
+ (locrefs :initarg :locrefs)
+ (idxclass :initarg :idxclass)
+ (subentries :initform '())))
+
+(defun make-index-entry (&key (main-key '()) (merge-key '())
+ (sort-key '()) (print-key '())
+ (locrefs '()) (idxclass nil)
+ &allow-other-keys)
+ (make-instance 'index-entry
+ :main-key main-key :merge-key merge-key
+ :sort-key sort-key :print-key print-key
+ :locrefs locrefs :idxclass idxclass))
+;; line 108 "idxentry.nw"
+(defvar *currently-processed-indexentry*)
+;; line 116 "idxentry.nw"
+(defmacro add-location-reference-to-indexentry (idxent locref)
+ `(PROGN
+ (UNLESS (SOME #'(LAMBDA (LREF)
+ (LOCREF= ,locref LREF))
+ (GET-LOCREFS ,idxent))
+ (SET-LOCREFS (CONS ,locref (GET-LOCREFS ,idxent))
+ ,idxent))
+ ,idxent))
+;; line 249 "idxentry.nw"
+(defun convert-sublists-to-group-objects (list-of-sublists
+ object-type
+ &key (initializer-func nil))
+ (mapcar #'(lambda (sublist)
+ (let ((locref-grp (make-locref-group object-type sublist)))
+ (if initializer-func
+ (funcall initializer-func locref-grp)
+ locref-grp)))
+ list-of-sublists))
+;; line 267 "idxentry.nw"
+(defun convert-sublists-to-specialized-groups (list-of-sublists
+ convert-func
+ &optional
+ initializer-func)
+ (mapcar #'(lambda (sublist)
+ (let ((locref-grp
+ (make-locref-group (funcall convert-func sublist)
+ sublist)))
+ (if initializer-func
+ (funcall initializer-func locref-grp)
+ locref-grp)))
+ list-of-sublists))
+;; line 292 "idxentry.nw"
+(defclass locref-group ()
+ ((members :initarg :members)))
+
+(defun make-locref-group (group-class members)
+ (make-instance group-class :members members))
+
+(defgeneric process-group (group-object indexclass))
+;; line 322 "idxentry.nw"
+(defclass locref-class-group (locref-group)
+ ((locclass :initform 'nil)))
+;; line 327 "idxentry.nw"
+(defclass crossref-class-group (locref-group)
+ ((locclass :initform 'nil)))
+;; line 333 "idxentry.nw"
+(defun process-indexentry (idxent)
+ (setq *currently-processed-indexentry* idxent)
+ (when (>= (incf *current-number*) (caar *processing-percentage-list*))
+ (print-percent (pop *processing-percentage-list*)))
+ (set-locrefs (convert-sublists-to-specialized-groups
+ (split-list #'(lambda (locref)
+ (get-ordnum (get-locclass locref)))
+ (get-locrefs idxent)
+ :sortfunc #'<)
+ #'(lambda (sublist)
+ (typecase (car sublist)
+ (layered-location-reference 'locref-class-group)
+ (crossref-location-reference 'crossref-class-group)
+ (t (error "internal error in `process-indexentry'"))))
+ #'(lambda (locref-cls-grp)
+ (set-locclass (get-locclass
+ (car (get-members locref-cls-grp)))
+ locref-cls-grp)
+ locref-cls-grp))
+ idxent)
+ (mapc #'(lambda (locref-cls-grp)
+ (process-group locref-cls-grp *indexstyle*))
+ (get-locrefs idxent))
+ idxent)
+;; line 899 "idxentry.nw"
+(defmacro take-first (list)
+ `(AND ,list (LIST (CAR ,list))))
+
+(defun tree-location-references (locref-list
+ max-depth
+ &optional (curr-depth 1))
+ (cond ((or (endp locref-list) #| nothing more to do |#
+ (> curr-depth max-depth)) #| we reached the end |#
+ locref-list)
+ (t (let ((locref-slist
+ (split-list #'(lambda (locref)
+ (car (get-ordnums locref)))
+ locref-list
+ :sortfunc #'<)))
+ (mapcar
+ #'(lambda (sublist)
+ (let* ((locref (car sublist))
+ (ordnums (get-ordnums locref)))
+ (if (= 1 (length ordnums))
+ (progn #| length = 1 |#
+ (set-subrefs
+ (sort-locrefs
+ (tree-location-references (remove-first-layers
+ (cdr sublist))
+ max-depth
+ (1+ curr-depth)))
+ locref)
+ locref)
+ (let #| length > 1 |#
+ ((new-locref
+ (make-layered-location-reference
+ :layers (take-first (get-layers locref))
+ :ordnums (take-first (get-ordnums locref))
+ :locclass (get-locclass locref)
+ :catattr (get-last-in-group
+ (get-catattr locref))
+ )))
+ (set-subrefs
+ (sort-locrefs
+ (tree-location-references (remove-first-layers sublist)
+ max-depth
+ (1+ curr-depth)))
+ new-locref)
+ new-locref))))
+ locref-slist)))))
+;; line 947 "idxentry.nw"
+(defun remove-first-layers (locref-list)
+ (declare (inline))
+ (mapc #'(lambda (locref)
+ (typecase locref
+ (layered-location-reference
+ (set-layers (cdr (get-layers locref)) locref)
+ (set-ordnums (cdr (get-ordnums locref)) locref))
+ (location-range
+ (let ((first (get-first locref))
+ (last (get-last locref)))
+ (set-layers (cdr (get-layers locref)) locref)
+ (set-ordnums (cdr (get-ordnums locref)) locref)
+ (set-layers (cdr (get-layers first)) first)
+ (set-ordnums (cdr (get-ordnums first)) first)
+ (set-layers (cdr (get-layers last)) last)
+ (set-ordnums (cdr (get-ordnums last)) last)
+ ))))
+ locref-list)
+ locref-list)
+;; line 973 "idxentry.nw"
+(defun sort-locrefs (locref-list)
+ #+:ASSERT! (assert! (listp locref-list))
+ (sort locref-list
+ #'(lambda (locref-1 locref-2)
+ (locref-ordnum< (get-ordnums locref-1)
+ (get-ordnums locref-2)))))
+;; line 370 "idxentry.nw"
+(defmethod process-group ((locref-cls-grp locref-class-group)
+ (idxcls indexclass))
+ #+:XP
+ (when *locref-trace* (pprint-locref-group *logging-stream* locref-cls-grp
+ "Inital location-refrence group:"))
+ (apply-substitution-and-merge-rules locref-cls-grp idxcls)
+ #+:XP
+ (when *locref-trace* (pprint-locref-group *logging-stream* locref-cls-grp
+ "After subst- and merge-to-rules:"))
+ (build-ranges-in-locref-class-group locref-cls-grp idxcls)
+ #+:XP
+ (when *locref-trace* (pprint-locref-group *logging-stream* locref-cls-grp
+ "After build-ranges:"))
+ (remove-virtual-locrefs locref-cls-grp)
+ #+:XP
+ (when *locref-trace* (pprint-locref-group *logging-stream* locref-cls-grp
+ "After remove virtuals:"))
+ (separate-into-catattr-groups locref-cls-grp)
+ #+:XP
+ (when *locref-trace* (pprint-locref-group *logging-stream* locref-cls-grp
+ "After separate attr-groups:"))
+ locref-cls-grp)
+
+;; line 531 "idxentry.nw"
+(defmethod apply-substitution-and-merge-rules ((locref-cls-grp locref-class-group)
+ (idxcls indexclass))
+ (let ((locref-same-ordnum-grps
+ (split-same-locrefs (get-members locref-cls-grp))))
+ (set-members
+ (mapcan #'(lambda (locref-same-ordnum-grp)
+ (apply-merge-rules
+ idxcls
+ (apply-substitution-rules idxcls
+ locref-same-ordnum-grp)))
+ locref-same-ordnum-grps)
+ locref-cls-grp))
+ locref-cls-grp)
+
+;; line 553 "idxentry.nw"
+(defun split-same-locrefs (locrefs)
+ #+ASSERT! (assert! (listp locrefs))
+ (split-list #'(lambda (locref)
+ (get-ordnums locref))
+ locrefs
+ :sortfunc #'(lambda (locref-ordnum-1 locref-ordnum-2)
+ (locref-ordnum< locref-ordnum-1 locref-ordnum-2))
+ ))
+;; line 569 "idxentry.nw"
+(defmethod apply-substitution-rules ((idxcls indexclass)
+ (locrefs list))
+ (let ((substitute-locref (get-substitution-subst-hook idxcls)))
+ (delete-if #'null
+ (mapcar #'(lambda (test-locref)
+ (cond ((some #'(lambda (against-locref)
+ (substitutable-p idxcls test-locref
+ against-locref))
+ locrefs)
+ (funcall substitute-locref test-locref))
+ (t test-locref)))
+ locrefs))))
+;; line 590 "idxentry.nw"
+(defmethod substitutable-p ((idxcls indexclass)
+ (test-locref layered-location-reference)
+ (against-locref layered-location-reference))
+ (cond ((eql test-locref against-locref)
+ nil)
+ ((and (state-normal-p against-locref)
+ (relation-p (get-implicit-subst-rules idxcls)
+ (get-catattr against-locref)
+ (get-catattr test-locref))))
+ (t nil)))
+;; line 638 "idxentry.nw"
+(defmethod apply-merge-rules ((idxcls indexclass) (locrefs list))
+ (let ((merge-rules (get-merge-rules idxcls))
+ (drop-if-merged-rules (get-drop-if-merged-rules idxcls)))
+ (nconc locrefs
+ (mapcan #'(lambda (locref)
+ (mapcan #'(lambda (catattr)
+ (let ((new-locref
+ (make-layered-location-reference
+ :virtual t
+ :layers (get-layers locref)
+ :ordnums (get-ordnums locref)
+ :catattr catattr
+ :locclass (get-locclass locref)
+ :attribute (get-attribute locref)
+ :string (get-locref-string locref)
+ )))
+ (when (relation-p drop-if-merged-rules
+ (get-catattr locref)
+ catattr)
+ (set-origin locref new-locref))
+ (list new-locref)))
+ (relation-set merge-rules (get-catattr locref))))
+ locrefs))))
+;; line 721 "idxentry.nw"
+(defun build-ranges-in-locref-class-group (locref-cls-grp idxcls)
+ (let ((locref-same-catattr-grps
+ (split-list #'(lambda (locref) (get-catattr locref))
+ (get-members locref-cls-grp)
+ :sortfunc #'(lambda (x y)
+ (< (get-processing-ordnum x)
+ (get-processing-ordnum y))))))
+ (set-members (mapcan #'(lambda (catattr-sublist)
+ (let ((processed-locrefs
+ (build-ranges catattr-sublist
+ idxcls
+ (get-locclass
+ (car catattr-sublist)))))
+ (when *locref-trace*
+ (let ((*print-pretty* t))
+ (gol t "~&after build-ranges:")
+ (pprint-newline :mandatory *logging-stream*)
+ (pprint-newline :mandatory *logging-stream*)
+ (write processed-locrefs
+ :stream *logging-stream*)))
+ (let ((s2 (mapcar
+ #'(lambda (x)
+ (post-process
+ x
+ #'set-state-deleted))
+ processed-locrefs)))
+ (when *locref-trace*
+ (let ((*print-pretty* t))
+ (gol t "~&after set-state-deleted:")
+ (pprint-newline :mandatory *logging-stream*)
+ (pprint-newline :mandatory *logging-stream*)
+ (write s2 :stream *logging-stream*)))
+ s2)))
+ locref-same-catattr-grps)
+ locref-cls-grp)))
+;; line 396 "idxentry.nw"
+(defmethod process-group ((crossref-cls-grp crossref-class-group)
+ (idxcls indexclass))
+ (let ((cross-references (get-members crossref-cls-grp)))
+ (typecase (get-locclass (car cross-references))
+ (verified-crossref-location-class
+ (mapc #'(lambda (xref)
+ (let* ((target (get-target xref))
+ (merge-key-target
+ #+:ORDRULES (gen-keyword-mergekey-list target)
+ #-:ORDRULES target))
+ (unless (lookup-indexentry merge-key-target)
+ (oops "Cross-reference-target ~S does not exist!"
+ target))))
+ cross-references))
+ (unverified-crossref-location-class)
+ (t (error "INTERNAL ERROR in process-group"))))
+ crossref-cls-grp)
+;; line 422 "idxentry.nw"
+(defun remove-virtual-locrefs (locref-cls-grp)
+ (set-members (delete-if #'(lambda (object)
+ (and (typep object 'location-reference)
+ (state-virtual-p object)))
+ (get-members locref-cls-grp))
+ locref-cls-grp))
+;; line 794 "idxentry.nw"
+(defclass category-attribute-group (locref-group)
+ ((ordnum :initform 'nil)))
+
+(defun separate-into-catattr-groups (locref-cls-grp)
+ (set-members (convert-sublists-to-group-objects
+ (split-list #'(lambda (object)
+ (get-catattr-grp-ordnum (get-catattr object)))
+ (get-members locref-cls-grp)
+ :sortfunc #'<)
+ 'category-attribute-group)
+ locref-cls-grp)
+ (mapc #'(lambda (catattr-grp)
+ (set-ordnum (get-catattr-grp-ordnum
+ (get-catattr (car (get-members catattr-grp))))
+ catattr-grp)
+ (set-members
+ (sort (tree-location-references (get-members catattr-grp)
+ (get-hierdepth
+ (get-locclass locref-cls-grp)))
+ #'(lambda (object-1 object-2)
+ (let ((ordnum-1 (get-ordnums object-1))
+ (ordnum-2 (get-ordnums object-2)))
+ (or (locref-ordnum< ordnum-1 ordnum-2)
+ (and (locref-ordnum= ordnum-1 ordnum-2)
+ (< (get-sort-ordnum (get-catattr object-1))
+ (get-sort-ordnum (get-catattr object-2))))))))
+ catattr-grp))
+ (get-members locref-cls-grp))
+ locref-cls-grp)
+
+#|
+(defun separate-into-catattr-groups-old-version (locref-cls-grp)
+ (set-members (convert-sublists-to-group-objects
+ (split-list #'(lambda (object)
+ (get-catattr-grp-ordnum (get-catattr object)))
+ #'<
+ (get-members locref-cls-grp))
+ 'category-attribute-group)
+ locref-cls-grp)
+ (mapc #'(lambda (catattr-grp)
+ (set-ordnum (get-catattr-grp-ordnum
+ (get-catattr (car (get-members catattr-grp))))
+ catattr-grp)
+ (set-members
+ (sort (get-members catattr-grp)
+ #'(lambda (object-1 object-2)
+ (let ((ordnum-1 (get-ordnums object-1))
+ (ordnum-2 (get-ordnums object-2)))
+ (or (locref-ordnum< ordnum-1 ordnum-2)
+ (and (locref-ordnum= ordnum-1 ordnum-2)
+ (< (get-sort-ordnum (get-catattr object-1))
+ (get-sort-ordnum (get-catattr object-2))))))))
+ catattr-grp))
+ (get-members locref-cls-grp))
+ locref-cls-grp)
+|#
+
+;; line 992 "idxentry.nw"
+(eval-when (compile load eval)
+
+;; line 127 "idxentry.nw"
+(export '(index-entry make-index-entry
+ add-location-reference-to-indexentry))
+;; line 360 "idxentry.nw"
+(export '(locref-group get-members
+ locref-class-group crossref-class-group get-locclass
+ make-locref-group process-group process-indexentry))
+;; line 603 "idxentry.nw"
+(export '(process-group split-same-locrefs
+ apply-substitution-rules substitutable-p))
+;; line 664 "idxentry.nw"
+(export '(apply-merge-rules))
+;; line 853 "idxentry.nw"
+(export '(category-attribute-group))
+;; line 1021 "idxentry.nw"
+(export '(*percentage-list* print-rest-of-percentages print-percent))
+;; line 994 "idxentry.nw"
+ )
+;; line 594 "ranges.nw"
+;; $Id: ranges.nw,v 1.11 1997/03/26 16:18:41 kehr Exp $
+
+;; line 68 "ranges.nw"
+(defclass location-range ()
+ ((length :initarg :length)
+ (first :initarg :first)
+ (last :initarg :last)
+ (layers :initarg :layers)
+ (ordnums :initarg :ordnums)
+ (inner :initarg :inner)
+ (locclass :initarg :locclass)
+ (catattr :initarg :catattr)
+ (subrefs :initform '())))
+
+(defun make-location-range (&key length first last first-ordnum inner locclass)
+ (make-instance 'location-range
+ :length length
+ :first first
+ :last last
+ :inner inner
+ :ordnums first-ordnum
+ :layers (get-layers first)
+ :locclass locclass
+ :catattr (get-catattr first)))
+;; line 581 "ranges.nw"
+(defun ordnum-successor-p (ordnums-1 ordnums-2)
+ (declare (inline))
+ (and ordnums-1 #|is there really something in it, or we are about to start?|#
+ (equal (butlast ordnums-1) (butlast ordnums-2))
+ (equal (1+ (car (last ordnums-1)))
+ (car (last ordnums-2)))))
+;; line 143 "ranges.nw"
+(defmethod build-ranges ((locref-list list)
+ (idxcls indexclass)
+ (loccls var-location-class))
+ locref-list)
+;; line 321 "ranges.nw"
+(defmacro newstat (s)
+ `(setq new-state ,s))
+
+(defmacro pushl ()
+ `(progn
+ (setq curr-ordnum (get-ordnums locref))
+ (unless locref-stack
+ (setq first-ordnum curr-ordnum)
+ (setq first-locref locref))
+ (setq prev-ordnum curr-ordnum)
+ (push locrefs locref-stack)))
+
+(defmacro pushone ()
+ `(progn
+ (setq curr-ordnum (get-ordnums locref))
+ (unless locref-stack
+ (setq first-ordnum curr-ordnum)
+ (setq first-locref locref))
+ (setq prev-ordnum curr-ordnum)
+ (push (list (car locrefs)) locref-stack)))
+
+(defmacro set-open-range ()
+ `(setq last-open-locref locref))
+
+(defmacro keep ()
+ `(setq back-flag t))
+
+(defmacro make-range ()
+ `(setq make-flag t))
+;; line 197 "ranges.nw"
+(defmethod build-ranges ((locref-list list)
+ (idxcls indexclass)
+ (loccls standard-location-class))
+ (let ((valid-list (mapcan #'(lambda (locref)
+ (unless (state-deleted-p locref)
+ (list locref)))
+ locref-list)))
+ (ifnot valid-list
+ '()
+ (ifnot (joining-allowed-p loccls)
+ valid-list
+ (let ((same-ordnum-list (split-same-locrefs valid-list))
+
+;; line 353 "ranges.nw"
+(locref-stack '())
+(result-list '())
+(state :START)
+(join-length (get-join-length loccls))
+new-state
+open-p close-p open+close-p no-typ-p list-end
+make-flag back-flag
+locrefs locref last-open-locref first-locref
+first-ordnum prev-ordnum curr-ordnum
+;; line 209 "ranges.nw"
+ )
+ (loop
+
+;; line 365 "ranges.nw"
+(setq locrefs (car same-ordnum-list))
+(setq list-end (null locrefs))
+(setq locref (car locrefs))
+(setq open-p (find-if #'(lambda (locref)
+ (rangeattr-open-p (get-rangeattr locref)))
+ locrefs))
+(setq close-p (find-if #'(lambda (locref)
+ (rangeattr-close-p (get-rangeattr locref)))
+ locrefs))
+(setq open+close-p (and open-p close-p))
+(setq no-typ-p (not (or open-p close-p)))
+;; line 212 "ranges.nw"
+ (ecase state
+ (:START
+;; line 230 "ranges.nw"
+(cond (list-end (return (apply #'nconc #| see note below for explanation |#
+ (apply #'nconc result-list))))
+ (no-typ-p (newstat :READ) (pushl))
+ (open+close-p (newstat :READ) (pushone))
+ (open-p (newstat :OPEN-RANGE) (pushl) (set-open-range))
+ (close-p (warn-invalid-close locref) (newstat :START))
+ (t (error
+ "INTERNAL-ERROR in build-ranges - :START")))
+;; line 213 "ranges.nw"
+ )
+ (:READ
+;; line 267 "ranges.nw"
+(if list-end
+ (progn (newstat :START) (make-range))
+ (progn
+ (setq curr-ordnum (get-ordnums locref))
+ (let ((succ-p (ordnum-successor-p prev-ordnum curr-ordnum)))
+ (cond ((and succ-p no-typ-p) (pushl))
+ ((and succ-p open+close-p) (pushone))
+ ((or no-typ-p
+ (not (and succ-p
+ open-p))) (newstat :START) (keep) (make-range))
+ (open-p (newstat :OPEN-RANGE)
+ (pushl) (set-open-range))
+ (close-p (warn-invalid-close locref) (newstat :READ))
+ (t (error "INTERNAL-ERROR in build-ranges - :READ"))))))
+;; line 214 "ranges.nw"
+ )
+ (:OPEN-RANGE
+;; line 288 "ranges.nw"
+(cond (list-end
+;; line 297 "ranges.nw"
+(warn
+ (with-output-to-string (s)
+ (format s "Found no :close-range matching an already opened one!~%")
+ (format s "Location-reference is ~A in keyword ~A.~%"
+ (get-locref-string last-open-locref)
+ (get-main-key *currently-processed-indexentry*))
+ (format s "Maybe I lost some of the regular location-references.~%")))
+;; line 288 "ranges.nw"
+ (newstat :START))
+ ((or no-typ-p open+close-p) (pushl))
+ (open-p
+;; line 307 "ranges.nw"
+(warn
+ (with-output-to-string (s)
+ (format s "Found :open-range that was already opened!~%")
+ (format s "Location-references are ~A and ~A in keyword ~A.~%"
+ (get-locref-string last-open-locref)
+ (get-locref-string locref)
+ (get-main-key *currently-processed-indexentry*))
+ (format s "I'll continue and ignore this.~%")))
+;; line 291 "ranges.nw"
+ (newstat :OPEN-RANGE))
+ (close-p (newstat :READ) (pushl))
+ (t (error "INTERNAL-ERROR in build-ranges - :OPEN-RANGE")))
+;; line 215 "ranges.nw"
+ ))
+
+;; line 402 "ranges.nw"
+(when make-flag
+ (let ((range-len (- (car (last prev-ordnum)) (car (last first-ordnum)))))
+ (if (>= range-len join-length)
+ (push (list (list
+ (make-location-range :first-ordnum first-ordnum
+ :locclass loccls
+ :inner locref-stack
+ :first first-locref
+ :last (caar locref-stack)
+ :length range-len)))
+ result-list)
+ (push locref-stack result-list))
+ (setq locref-stack '())
+ (setq make-flag nil)))
+(if back-flag
+ (setq back-flag nil)
+ (setq same-ordnum-list (cdr same-ordnum-list)))
+(setq state new-state)
+;; line 216 "ranges.nw"
+ ))))))
+;; line 241 "ranges.nw"
+(defun warn-invalid-close (locref)
+ (warn
+ (with-output-to-string (s)
+ (format s "Found a :close-range in the index that wasn't opened before!~%")
+ (format s "Location-reference is ~A in keyword ~A~%"
+ (get-locref-string locref)
+ (get-main-key *currently-processed-indexentry*))
+ (format s "I'll continue and ignore this.~%"))))
+;; line 509 "ranges.nw"
+(defmethod post-process ((locrange location-range) (drop-function function))
+ (let ((locref-list (apply #'nconc (get-inner locrange))))
+ (cond ((>= (get-length locrange)
+ (get-join-length (get-locclass locrange)))
+ (mapc #'(lambda (locref)
+ (let ((origin (get-origin locref)))
+ (when origin
+ (funcall drop-function origin))))
+ locref-list)
+ ;;(set-inner '() locrange)
+ locrange)
+ (t locref-list))))
+
+;(defmethod post-process ((locref-list list) x)
+; (declare (ignore x))
+; locref-list)
+
+(defmethod post-process ((locref location-reference) x)
+ (declare (ignore x))
+ locref)
+
+;; line 600 "ranges.nw"
+(eval-when (compile load eval)
+
+;; line 92 "ranges.nw"
+(export '(location-range get-first get-last get-length))
+;; line 602 "ranges.nw"
+ )
+;; line 88 "index.nw"
+(defparameter *index-entry-table* nil) #| faster access to the entry-table |#
+;; line 69 "index.nw"
+(defconstant *all-hierarchy-layers* MOST-POSITIVE-FIXNUM)
+
+(defclass base-index ()
+ ((entry-table :initform (make-hash-table :test #'equal))
+ (entry-list :initform '())
+ (entries :initform '())
+ (idxclass :initarg :idxclass)
+ (hierdepth :initform *all-hierarchy-layers*)))
+
+(defun make-base-index (idxclass)
+ (make-instance 'base-index :idxclass idxclass))
+;; line 542 "index.nw"
+(defclass letter-group ()
+ ((members :initarg :members :type list)
+ (group-definition :initarg :group-definition)))
+;; line 555 "index.nw"
+(defun make-letter-group (members)
+ (make-instance 'letter-group
+ :members members
+ :group-definition (match-letter-group
+ *indexstyle*
+ (car (get-sort-key (car members))))))
+
+;; line 273 "index.nw"
+(defun add-layered-locref-indexentry (&key
+ (entry-table *index-entry-table*)
+ (idxcls *indexstyle*)
+ locref main-key
+ (merge-key '())
+ (print-key '())
+ (open-range nil) (close-range nil)
+ (catattr nil) (attribute nil))
+ #+:ASSERT! (assert! (and main-key locref))
+
+ (if (and open-range close-range)
+
+;; line 320 "index.nw"
+(nraw "specification of both :open-range and :close-range is invalid! (ignored)")
+;; line 285 "index.nw"
+ (progn
+ (when (or (not catattr)
+ (string= catattr ""))
+ (setq catattr "default"))
+ (let ((catattr-obj (lookup-catattr idxcls catattr)))
+ (if (not catattr-obj)
+ (nraw "unknown attribute `~A'! (ignored)" catattr)
+ (multiple-value-bind (num location-reference)
+ (create-location-reference-from-string
+ locref catattr-obj attribute)
+ (when (eql 1 num)
+ #| ;
+ Only one vaild location-reference! Use #'eql and
+ not #'= since we compare num against NIL, too.
+ |#
+
+;; line 359 "index.nw"
+#+:ORDRULES (unless merge-key
+ (setq merge-key (gen-keyword-mergekey-list main-key)))
+#-:ORDRULES (unless merge-key (setq merge-key main-key))
+;; line 301 "index.nw"
+ (cond (open-range (set-rangeattr-open location-reference))
+ (close-range (set-rangeattr-close location-reference)))
+ (let ((old-entry (gethash merge-key entry-table)))
+ (if old-entry
+ (setf (gethash merge-key entry-table)
+ (join-indexentries
+ old-entry;;(gethash merge-key entry-table)
+ main-key print-key
+ location-reference))
+ (setf (gethash merge-key entry-table)
+ (make-index-entry :main-key main-key
+ :merge-key merge-key
+ :print-key print-key
+ :locrefs (list
+ location-reference)
+ :indexclass idxcls)))))))))))
+;; line 324 "index.nw"
+(defun add-crossref-indexentry (&key
+ (entry-table *index-entry-table*)
+ (idxcls *indexstyle*)
+ (merge-key '())
+ (print-key '())
+ main-key
+ xref
+ xref-class-name
+ (attribute nil))
+ #+:ASSERT! (assert! (and main-key xref xref-class-name))
+
+ (unless xref-class-name (setq xref-class-name "default"))
+ (let ((xref-class (cdr (lookup-crossref-class idxcls xref-class-name))))
+ (if (not xref-class)
+ (nraw "unknown cross-reference-class `~A'! (ignored)~%"
+ xref-class-name)
+ (let ((cross-reference (create-cross-reference xref-class
+ xref attribute)))
+ (when cross-reference
+
+;; line 359 "index.nw"
+#+:ORDRULES (unless merge-key
+ (setq merge-key (gen-keyword-mergekey-list main-key)))
+#-:ORDRULES (unless merge-key (setq merge-key main-key))
+;; line 344 "index.nw"
+ (let ((old-entry (gethash merge-key entry-table)))
+ (if old-entry
+ (setf (gethash merge-key entry-table)
+ (join-indexentries old-entry ;;(gethash merge-key entry-table)
+ main-key print-key
+ cross-reference))
+ (setf (gethash merge-key entry-table)
+ (make-index-entry :main-key main-key
+ :merge-key merge-key
+ :print-key print-key
+ :locrefs (list cross-reference)
+ :indexclass idxcls)))))))))
+;; line 367 "index.nw"
+#+:ORDRULES
+(defun gen-keyword-mergekey-list (list-of-strings)
+ #+ASSERT! (assert! (and (not (null list-of-strings))
+ (listp list-of-strings)))
+ (let ((res (mapcar #'(lambda (str)
+ (gen-keyword-mergekey str))
+ list-of-strings)))
+ (flush-ordrules-message-buffer)
+ res))
+
+#+:ORDRULES
+(defun gen-keyword-sortkey-list (list-of-strings run)
+ #+ASSERT! (assert! (and (not (null list-of-strings))
+ (listp list-of-strings)
+ (<= 0 run) (run < 8)))
+ (let ((res (mapcar #'(lambda (str)
+ (gen-keyword-sortkey str run))
+ list-of-strings)))
+ (flush-ordrules-message-buffer)
+ res))
+;; line 398 "index.nw"
+(defun join-indexentries (idxent main-key print-key locref)
+ (let ((old-main-key (get-main-key idxent))
+ (old-print-key (get-print-key idxent)))
+ (unless old-main-key (set-main-key main-key idxent))
+ (set-print-key (mapcar #'(lambda (old curr)
+ (or old curr))
+ old-print-key print-key)
+ idxent)
+ ;; (info "~&(join-indexentries :old-main-key ~S :old-print-key ~S :new-print-key ~S)"
+ ;; old-main-key old-print-key (get-print-key idxent))
+ (add-location-reference-to-indexentry idxent locref)))
+;; line 438 "index.nw"
+(defun create-location-reference-from-string (locref-str catattr attribute)
+ (let* ((idxcls *indexstyle*))
+ (multiple-value-bind (num locref)
+ (lookup-locref-cache idxcls locref-str)
+ (if num #| something was found! |#
+ (case num
+ (0
+;; line 474 "index.nw"
+(nraw "location-reference ~S did not match any location-class! (ignored)"
+ locref-str)
+;; line 445 "index.nw"
+ (values nil nil))
+ (1 (values 1 (copy-locref-from-template locref catattr attribute))
+ #| return its only member |#)
+ (t
+;; line 469 "index.nw"
+(nraw "location-reference ~S did match multiple location-classes! (taking first one)"
+ locref-str)
+;; line 449 "index.nw"
+ (values num (copy-locref-from-template locref catattr attribute))
+ #| return a copy of the stored template |#))
+ (let ((locref-list
+ (map-location-classes
+ idxcls
+ #'(lambda (idxcls loccls)
+ (declare (ignore idxcls))
+ (build-location-reference loccls locref-str
+ catattr attribute)))))
+ (case (length locref-list)
+ (0
+;; line 474 "index.nw"
+(nraw "location-reference ~S did not match any location-class! (ignored)"
+ locref-str)
+;; line 460 "index.nw"
+ (add-locref-cache idxcls locref-str 0 nil))
+ (1 (add-locref-cache idxcls locref-str 1 (car locref-list))
+ #| return its only member |#)
+ (t
+;; line 469 "index.nw"
+(nraw "location-reference ~S did match multiple location-classes! (taking first one)"
+ locref-str)
+;; line 464 "index.nw"
+ (add-locref-cache idxcls locref-str 1 (car locref-list))
+ #| return its first member |#)))))))
+;; line 482 "index.nw"
+(defun copy-locref-from-template (locref catattr attribute)
+ (declare (inline))
+ (make-layered-location-reference :catattr catattr
+ :attribute attribute
+ :string (get-locref-string locref)
+ :locclass (get-locclass locref)
+ :layers (copy-list (get-layers locref))
+ :ordnums (copy-list (get-ordnums locref))))
+;; line 727 "index.nw"
+(defun sort-indexentries (indexentries)
+ #+:ASSERT! (assert! (listp indexentries))
+ (gol t "~&sort-indexentries: ~S" *sort-rule-orientations*)
+ (sort indexentries
+ #'(lambda (idxent-1 idxent-2)
+ (multiple-value-bind (less-equal? equal?)
+ (strlist<= (get-sort-key idxent-1)
+ (get-sort-key idxent-2)
+ (first *sort-rule-orientations*))
+ (if equal?
+ (sort-other-runs (get-merge-key idxent-1)
+ (get-merge-key idxent-2)
+ (rest *sort-rule-orientations*)
+ 1)
+ less-equal?)))))
+;; line 751 "index.nw"
+(defun sort-other-runs (merge-key-1 merge-key-2 orientations run)
+ (gol t "~&sort-other-runs: ~S ~S ~S ~S."
+ merge-key-1 merge-key-2 orientations run)
+ (cond ((endp orientations)
+ (nraw "Sort rules could not define exact order of key ~S."
+ merge-key-1)
+ nil)
+ (t (let ((key-1 (mapcar #'(lambda (key)
+ (gen-keyword-sortkey key run))
+ merge-key-1))
+ (key-2 (mapcar #'(lambda (key)
+ (gen-keyword-sortkey key run))
+ merge-key-2)))
+ (flush-ordrules-message-buffer)
+ (multiple-value-bind (less-equal? equal?)
+ (strlist<= key-1 key-2 (first orientations))
+ (if equal?
+ (sort-other-runs merge-key-1 merge-key-2
+ (rest orientations) (1+ run))
+ less-equal?))))))
+;; line 782 "index.nw"
+(defun oriented-string (string orientation)
+ (declare (inline))
+ (cond ((eql orientation 'forward) string)
+ ((eql orientation 'backward) (reverse string))
+ (t (error "INDEX:ORIENTED-STRING wrong orientation!"))))
+;; line 793 "index.nw"
+(defun strlist<= (slist-1 slist-2 orientation)
+ (declare (inline))
+ (cond ((endp slist-1) (values t (endp slist-2)))
+ ((endp slist-2) (values nil nil))
+ (t (let ((str-1 (oriented-string (first slist-1) orientation))
+ (str-2 (oriented-string (first slist-2) orientation)))
+ (let ((pos (string/= str-1 str-2)))
+ (if pos
+ (let ((lt (string< str-1 str-2)))
+ (if lt
+ (values t nil)
+ (values nil (string= str-1 str-2))))
+ (strlist<= (cdr slist-1) (cdr slist-2) orientation)))))))
+#|
+(strlist<= '("foo") '("foo") 'forward)
+(strlist<= '("fool") '("foo") 'forward)
+(strlist<= '("foo") '("fool") 'forward)
+(strlist<= '("foo") '("fool") 'backward)
+(strlist<= '("foo") '("foo" "bar") 'forward)
+(strlist<= '("foo" "bar") '("foo") 'forward)
+(strlist<= '("foo" "bar") '("foo") 'backward)
+|#
+
+
+#+OLDVER
+(defun strlist< (string-list-1 string-list-2)
+ (declare (inline))
+ (do ((rest-1 string-list-1 (cdr rest-1))
+ (rest-2 string-list-2 (cdr rest-2)))
+ ((or (endp rest-1) (endp rest-2)
+ (string/= (first rest-1) (first rest-2)))
+ (or (endp rest-1)
+ (if (endp rest-2)
+ 'nil
+ (string< (first rest-1) (first rest-2)))))))
+;; line 504 "index.nw"
+(defmethod process-index ((index base-index))
+ (let ((hash-list '()))
+ (maphash #'(lambda (key idxentry)
+ (declare (ignore key))
+ (setq hash-list (cons idxentry hash-list)))
+ (get-entry-table index))
+ (set-entry-list hash-list index)
+ (build-indexentry-tree index)
+
+ (setq *number-of-indexentries* (length (get-entry-list index)))
+ (setq *current-number* 0)
+ (setq *percentage-list*
+ (mapcar #'(lambda (percent)
+ (cons (truncate (* (/ percent 100)
+ *number-of-indexentries*))
+ percent))
+ ;; MOST-POSITIVE-FIXNUM acts as sentinel such that
+ ;; we never run out of elements
+ `(10 20 30 40 50 60 70 80 90 100 ,MOST-POSITIVE-FIXNUM)))
+ (setq *processing-percentage-list* *percentage-list*)
+ (mapc #'process-indexentry (get-entry-list index))
+ (print-rest-of-percentages *processing-percentage-list*)
+ index))
+;; line 568 "index.nw"
+(defmethod build-indexentry-tree ((index base-index))
+ (let ((index-hierdepth (get-hierdepth index)))
+ (gol t "~&~%Building indexentry-tree:~%")
+ (gol t "Hierdepth of index is ~S~%~%"
+ (if (= index-hierdepth most-positive-fixnum)
+ :tree index-hierdepth))
+ (set-entries (build-indexentry-tree-recursive (get-entry-list index)
+ index-hierdepth)
+ index)
+ (gol t "~&~%Forming letter-groups:~%")
+ (let ((letter-groups (split-list #'(lambda (idxent)
+ (get-ordnum
+ (match-letter-group
+ *indexstyle*
+ (car (get-sort-key idxent)))))
+ (get-entries index)
+ :sortfunc #'<)))
+ (set-entries (mapcar #'(lambda (lg-indexentries)
+ (make-letter-group
+ (sort-indexentries lg-indexentries)))
+ letter-groups)
+ index))))
+;; line 622 "index.nw"
+(defun build-indexentry-tree-recursive (idxent-list
+ max-depth
+ &optional (curr-depth 1))
+ (cond ((endp idxent-list) idxent-list) #| nothing more to do |#
+ ((> curr-depth max-depth) #| we reached the end |#
+ (gen-all-sort-keys idxent-list) #| this is the then case |#
+ )
+ (t (let ((idxent-slist
+ (split-list #'(lambda (idxent)
+ (car (get-merge-key idxent)))
+ idxent-list
+ :headfunc
+ #'(lambda (idxent)
+ (= 1 (length (get-merge-key idxent)))))))
+ (mapcar
+ #'(lambda (sublist)
+ (let* ((idxent (car sublist))
+ (merge-key (get-merge-key idxent)))
+ (if (= 1 (length merge-key))
+ (progn #| length = 1 |#
+ (set-sort-key #-:ORDRULES merge-key
+ #+:ORDRULES (gen-keyword-sortkey-list
+ merge-key 0)
+ idxent)
+ (set-subentries
+ (sort-indexentries
+ (build-indexentry-tree-recursive
+ (remove-first-keywords (cdr sublist))
+ max-depth
+ (1+ curr-depth)))
+ idxent)
+ idxent)
+ (let* #| length > 1 |#
+ ((main-key (get-main-key idxent))
+ (new-merge-key (take-first merge-key))
+ (some-print-key (find-print-key sublist))
+ (new-print-key (list (or some-print-key
+ (car main-key))))
+ (new-idxent
+ (make-index-entry
+ :main-key (take-first main-key)
+ :merge-key new-merge-key
+ :print-key new-print-key
+ :sort-key
+ #-:ORDRULES new-merge-key
+ #+:ORDRULES (gen-keyword-sortkey-list
+ new-merge-key 0)
+ :idxclass (get-idxclass idxent))))
+ ;; (info "~&(treeing :main ~S :some-print ~S :new-print ~S)"
+ ;; main-key some-print-key new-print-key)
+ (set-subentries
+ (sort-indexentries
+ (build-indexentry-tree-recursive
+ (remove-first-keywords sublist)
+ max-depth
+ (1+ curr-depth)))
+ new-idxent)
+ new-idxent))))
+ idxent-slist)))))
+
+(defun find-print-key (idxent-list)
+ (some #'(lambda (idxent)
+ (car (get-print-key idxent)))
+ idxent-list))
+;; line 689 "index.nw"
+(defun remove-first-keywords (idxent-list)
+ (declare (inline))
+ (mapc #'(lambda (idxent)
+ (setf (slot-value idxent 'merge-key)
+ (cdr (slot-value idxent 'merge-key)))
+ (setf (slot-value idxent 'main-key)
+ (cdr (slot-value idxent 'main-key)))
+ (setf (slot-value idxent 'print-key)
+ (cdr (slot-value idxent 'print-key)))
+ )
+ idxent-list)
+ idxent-list)
+;; line 713 "index.nw"
+(defun gen-all-sort-keys (idxent-list)
+ (when idxent-list
+ (mapc #'(lambda (idxent)
+ (set-sort-key #-:ORDRULES (get-merge-key idxent)
+ #+:ORDRULES (gen-keyword-sortkey-list
+ (get-merge-key idxent) 0)
+ idxent))
+ idxent-list))
+ idxent-list)
+;; line 94 "index.nw"
+(defparameter *index* nil)
+
+(defun create-index ()
+ (setq *index* (make-base-index *indexstyle*))
+ (setq *index-entry-table* (get-entry-table *index*))
+ *index*)
+
+(create-index)
+;; line 421 "index.nw"
+(defun lookup-indexentry (key &optional (index-entry-table *index-entry-table*))
+ (gethash key index-entry-table))
+
+;; line 258 "index.nw"
+(eval-when (compile load eval)
+ (defparameter *raw-index-interface-definitions*
+ '(indexentry)))
+;; line 165 "index.nw"
+(defmacro indexentry (&whole whole &rest args)
+ (destructuring-switch-bind (&key
+ key print tkey merge attr locref xref
+ &switch
+ (open-range :open-range)
+ (close-range :close-range))
+ args
+ (cond ((not (or key tkey))
+ (error "missing argument :key or :tkey in~%~S."))
+ ((and key tkey)
+ (error "you can't specify :key and :tkey at the same time in~%~S."
+ whole))
+ ((and locref xref)
+;; line 213 "index.nw"
+(error "you can't specify :locref and :xref at the same time in~%~S."
+ whole)
+
+;; line 177 "index.nw"
+ )
+ (t (progn
+ (if tkey
+ (multiple-value-setq (key print)
+ (tkey-to-normal-key tkey whole))
+ (when print;; check for correct key-length
+ (let ((keylen (length key)))
+ (unless (= keylen (length print))
+ (setq print;; take the first keylen elmts of print
+ (mapcar #'(lambda (x y) (declare (ignore y)) x)
+ key
+ (append print (make-list keylen))))))))
+ (cond ((not (listp key))
+ (error ":key ~S is not a list in~%~S." key whole))
+ ((not (listp print))
+ (error ":print ~S is not a list in~%~S." print whole))
+ (locref `(ADD-LAYERED-LOCREF-INDEXENTRY
+ :MAIN-KEY ',key
+ :PRINT-KEY ',print
+ :MERGE-KEY ',merge
+ :CATATTR ',attr
+ :LOCREF ',locref
+ :OPEN-RANGE ',open-range
+ :CLOSE-RANGE ',close-range))
+ (xref (when (or open-range close-range)
+
+;; line 221 "index.nw"
+(error "you can't specify :open-range or :close-range with :xref at the same time in~%~S."
+ whole)
+;; line 202 "index.nw"
+ )
+ (unless attr
+;; line 217 "index.nw"
+(error "missing :attr in combination with :xref in~%~S." whole)
+;; line 203 "index.nw"
+ )
+ `(ADD-CROSSREF-INDEXENTRY
+ :MAIN-KEY ',key
+ :PRINT-KEY ',print
+ :XREF ',xref
+ :XREF-CLASS-NAME ',attr))
+ (t
+;; line 226 "index.nw"
+(error "you must at least specify :locref or :xref in~%~S." whole)
+;; line 209 "index.nw"
+ )))))))
+;; line 238 "index.nw"
+(defun tkey-to-normal-key (tkey whole)
+ (when (not (listp tkey))
+;; line 254 "index.nw"
+(error "INDEXENTRY: invalid structure of :tkey in~%~S." tkey whole)
+;; line 239 "index.nw"
+ )
+ (let ((main-key '())
+ (print-key '()))
+ (mapc #'(lambda (key-elt)
+ (cond ((listp key-elt)
+ (push (car key-elt) main-key)
+ (if (cdr key-elt)
+ (push (cadr key-elt) print-key)
+ (push nil print-key)))
+ (t
+;; line 254 "index.nw"
+(error "INDEXENTRY: invalid structure of :tkey in~%~S." tkey whole)
+;; line 248 "index.nw"
+ )))
+ tkey)
+ (values (nreverse main-key) (nreverse print-key))))
+
+;; line 889 "index.nw"
+(eval-when (compile load eval)
+
+;; line 83 "index.nw"
+(export '(base-index make-base-index get-entries))
+;; line 105 "index.nw"
+(export '(*index* create-index))
+;; line 264 "index.nw"
+(export '*raw-index-interface-definitions*)
+(export *raw-index-interface-definitions*)
+;; line 412 "index.nw"
+(export '(add-locref-indexentry add-crossref-indexentry))
+;; line 530 "index.nw"
+(export '(process-index))
+;; line 564 "index.nw"
+(export '(letter-group get-members get-group-definition))
+;; line 891 "index.nw"
+ )
+
+;; line 1029 "idxentry.nw"
+#+:XP
+(set-pprint-dispatch 'index-entry
+ #'(lambda (s idxent)
+ (pprint-logical-block
+ (s nil :suffix "}")
+ (pprint-indent :block 2 s)
+ (write-string "Indexentry {" s)
+ (pprint-newline :mandatory s)
+ (write-string "main-key: " s)
+ (write (get-main-key idxent) :stream s)
+ (pprint-newline :mandatory s)
+ (write-string "merge-key: " s)
+ (write (get-merge-key idxent) :stream s)
+ (pprint-newline :mandatory s)
+ (write-string "sort-key: " s)
+ (write (get-sort-key idxent) :stream s)
+ (pprint-newline :mandatory s)
+ (pprint-logical-block
+ (s nil :suffix "}")
+ (write-string "Locrefs {" s)
+ (pprint-indent :block 2)
+ (pprint-newline :mandatory s)
+ (pprint-linear s (get-locrefs idxent)))
+ (pprint-newline :mandatory s)
+ (pprint-logical-block
+ (s nil :suffix "}")
+ (write-string "Subentries {" s)
+ (pprint-indent :block 2)
+ (pprint-newline :mandatory s)
+ (pprint-linear s (get-subentries idxent)))
+ (pprint-newline :mandatory s))
+ ))
+;; line 1071 "idxentry.nw"
+#+:XP
+(defun pprint-locref-group (s grp name)
+ (format s "~%")
+ (pprint-logical-block
+ (s nil :prefix "(" :suffix ")")
+ (write-string name s)
+ (write-string ":" s)
+ (when (typep grp 'category-attribute-group)
+ (write (get-ordnum grp) :stream s))
+ (pprint-indent :block 2 s)
+ (pprint-newline :mandatory s)
+ (pprint-fill s (get-members grp) nil)
+ (pprint-indent :block -1 s)
+ (pprint-newline :mandatory s)))
+
+#+:XP
+(defun set-pprint-locref-group-dispatch (class name &optional (rank 0))
+ (set-pprint-dispatch class
+ #'(lambda (s grp)
+ (pprint-locref-group s grp name))
+ rank))
+;; line 1107 "idxentry.nw"
+#+:XP
+(set-pprint-locref-group-dispatch 'locref-group
+ "LOCREF-GROUP" 0)
+#+:XP
+(set-pprint-locref-group-dispatch 'locref-class-group
+ "LOCREF-CLASS-GROUP" 1)
+#+:XP
+(set-pprint-locref-group-dispatch 'crossref-class-group
+ "CROSSREF-CLASS-GROUP" 2)
+#+:XP
+(set-pprint-locref-group-dispatch 'category-attribute-group
+ "CATEGORY-ATTRIBUTE-GROUP" 3)
+;; line 614 "ranges.nw"
+#+:XP
+(defun pprint-location-range (s range)
+ (pprint-logical-block
+ (s nil :prefix "[" :suffix "]")
+ (format s "range: ~D " (get-length range))
+ (pprint-newline :fill s)
+ (write-string " loccls: " s)
+ (write (get-locclass range) :stream s)
+ (pprint-newline :fill s)
+ (write-string " catattr: " s)
+ (write (get-catattr range) :stream s)
+ (format s "/~D" (get-sort-ordnum (get-catattr range)))
+ (pprint-newline :fill s)
+ (format s " ordnums: ~A " (get-ordnums range))
+ (pprint-newline :fill s)
+ (pprint-logical-block
+ (s nil :prefix "<" :suffix ">")
+ (write-string "first " s)
+ (pprint-newline :miser s)
+ (write (get-first range) :stream s))
+ (pprint-newline :mandatory s)
+ (pprint-logical-block
+ (s nil :prefix "<" :suffix ">")
+ (write-string "inner " s)
+ (pprint-newline :linear s)
+ (write (get-inner range) :stream s))
+ (pprint-newline :mandatory s)
+ (pprint-logical-block
+ (s nil :prefix "<" :suffix ">")
+ (write-string "last " s)
+ (pprint-newline :miser s)
+ (write (get-last range) :stream s))
+ (pprint-newline :mandatory s)))
+
+#+:XP
+(set-pprint-dispatch 'location-range #'pprint-location-range)
+
+;; line 868 "index.nw"
+(defvar *RCS-Identifier* '(
+;; line 998 "idxentry.nw"
+("idxentry" . "$Id: idxentry.nw,v 1.29 1997/03/27 17:17:25 kehr Exp $")
+;; line 895 "index.nw"
+("index" . "$Id: index.nw,v 1.31 1997/03/26 16:18:37 kehr Exp $")
+;; line 606 "ranges.nw"
+("ranges" . "$Id: ranges.nw,v 1.11 1997/03/26 16:18:41 kehr Exp $")
+;; line 868 "index.nw"
+ ))