path: root/Build/source/utils/xindy/src/idxstyle.lsp

;; line 289 "idxstyle.nw"
;; $Id: idxstyle.nw,v 1.19 1997/03/26 16:18:23 kehr Exp $
;;

(lisp:defpackage "IDXSTYLE")
(lisp:in-package "IDXSTYLE")
(lisp:provide "idxstyle")

#+CLISP (lisp:require "base")
#+CLISP (lisp:require "locref")

(eval-when (compile load eval)
  (lisp:use-package "CLOS")
  (lisp:use-package "COMMON-LISP")
  #+CLISP (lisp:use-package "EXT")
  #+(and :XP CLISP) (lisp:use-package "XP")
  #-CLISP (lisp:require "base")
  #-CLISP (lisp:require "locref")
  (lisp:use-package "BASE")
  (lisp:use-package "LOCREF")

;; line 472 "intface.nw"
(eval-when (eval load compile)
  (when (find-package "ORDRULES")
    (pushnew :ORDRULES *features*)))
;; line 306 "idxstyle.nw"
                                            ;; see submodule intface
  )

;; line 78 "idxstyle.nw"
(defparameter *indexstyle* nil)
(defparameter *indexstyle-readtable* (copy-readtable))
(defparameter *included-files* '())
(defvar *load-paths* "")
(defparameter *default-load-paths* *load-paths*)

(defparameter *default-minimum-range-length* 2)
(defparameter *default-locref-hierdepth*     0)

;; line 1151 "intface.nw"
;; $Id: intface.nw,v 1.30 1997/10/20 11:25:09 kehr Exp $

;; line 1016 "intface.nw"
;;; $Id: intface.nw,v 1.30 1997/10/20 11:25:09 kehr Exp $
;;;----------------------------------------------------------------------

;;;
;;; util-lib                    LISP Utitlity Library
;;;
;;; (history at end)


;(provide 'util-lib)
;(in-package 'util-lib)

(defvar whole)
(eval-when (compile load eval)
  (export '(destructuring-switch-bind &switch whole)))

(defmacro destructuring-switch-bind (lambdalist expr . body)
  "Similar to 'destructuring-bind' but also allows switch options at the
end of LAMBDALIST with the following syntax:

  &switch { var | (var key [defval]) | (var ({ key }*) [defval]) }*

In all cases VAR will be accessible in BODY as a variable.

If only VAR is specified, it is bound to the keyword with the same
name, if that keyword occured in EXPR. Otherwise it is bound to NIL.

If both a VAR and KEY were specified, VAR will be bound to KEY, if KEY
occured in EXPR and to NIL otherwise.

If VAR and a list of KEYs were specified, VAR will be bound to the
first KEY, which occured in EXPR. If none of the KEYS occured within
EXPR, VAR will be bound to NIL.

If DEFVAL was specified, variable will be bound to DEFVAL instead of
NIL in cases where no switch keyword was found in EXPR.
"

  (let* ((switchlist (member '&switch lambdalist))

         ;; 'remove' switches from lambdalist
         (lambdalist (ldiff lambdalist switchlist))

         ;; drop &switch keyword
         (switches (when switchlist (cdr switchlist)))

         ;; construct bindings for each switch and collect valid
         ;; keywords in 'switchkeys'
         (switchkeys '())
         (bindings
          (mapcar
           #'(lambda (spec)
               (cond

                 ;; spec simply consists of VAR
                 ((symbolp spec)
                    (let ((key (intern (symbol-name spec) 'keyword)))
                      (push key switchkeys)
                      `(,spec (FIND ,key <DESTRUCTURING-SWITCH-FORM>))
                      ))

                 ;; spec is (VAR form)
                 ((and (listp spec) (>= (list-length spec) 2))
                    (let ((var (first spec))
                          (keyspec (second spec))
                          (defval (when (cddr spec) (third spec))))
                      (cond
                        ;; spec is (VAR (KEY1 KEY2 ...))
                        ((listp keyspec)
                           `(,var
                             (COND
                               ,@(mapcar
                                  #'(lambda (key)
                                      (push key switchkeys)
                                      `((FIND ,key <DESTRUCTURING-SWITCH-FORM>)
                                        ,key))
                                  keyspec)
                               (T ,defval))))

                        ;; spec is (VAR KEY)
                        (t
                           (push keyspec switchkeys)
                           ` (,var (OR
                                    (FIND ,keyspec <DESTRUCTURING-SWITCH-FORM>)
                                    ,defval)))
                        )))

                 ;; illegal spec
                 (t (error "~A is not a valid switch specifier." spec))
                 ))
           switches))
         )

    ;; construct the expansion form
    ` (LET ((<DESTRUCTURING-SWITCH-FORM> ,expr))
        (LET ,bindings
          (HANDLER-CASE
              (DESTRUCTURING-BIND ,lambdalist
                  (SET-DIFFERENCE-KEEP-ORIGINAL-ORDER
                   <DESTRUCTURING-SWITCH-FORM>
                   ',switchkeys)
                ,@body)
            (ERROR (COND)
              (DECLARE (IGNORE COND))
              (ERROR "~&Syntax Error in ~S." WHOLE)
              )
            )
          )
        )
    ))

(defun set-difference-keep-original-order (set1 set2)
  (mapcan #'(lambda (elt)
              (unless (member elt set2)
                (list elt)))
          set1))

#|
(destructuring-switch-bind (name &rest args &key foo bar
                                 &switch
                                 on                     ; simple form
                                 (started :start)
                                 (speed (:fast :slow))
                                 (off :turn-off :turn-on) ; with switch key
                                 (choose (:one :two :three) :three))
                           '(width :foo 5 :bar 7 :on :turn-off :one)
  (list name foo bar args on started speed off choose))
|#
;; line 111 "intface.nw"
(eval-when (compile load eval)
  (defun stringify (name)
    (declare (inline))
    (etypecase name
      (symbol (symbol-name name))
      (string name)
      (number (write-to-string name)))))

(defun list-of-strings-p (x)
  (cond ((not (listp x)) nil)
        ((every #'(lambda (elt)
                    (or (stringp elt) (symbolp elt) (numberp elt)))
                x))))
;; line 136 "intface.nw"
(defun make-well-formed-list (attr-list)
  (mapcar #'(lambda (x)
              (cond ((null x)
                       (error "empty lists are not allowed !"))
                    ((or (symbolp x) (stringp x) (numberp x))
                       (list (stringify x)))
                    ((listp x)
                       (map-to-strings x))))
          attr-list))

(defun map-to-strings (slist)
  (mapcar #'(lambda (x)
              (cond ((null x)
                       (error "empty lists are not allowed !"))
                    ((or (symbolp x) (stringp x) (numberp x))
                       (stringify x))
                    ((listp  x)
                       (error "nesting level too deep !"))
                    (t (error "~S is not a string !" x))))
          slist))
;; line 185 "intface.nw"
(defun c-string-reader (stream char)
  (declare (ignore char))
  (let ((ch nil)
        (str (make-array 32
                         :element-type
                         #+CLISP 'string-char
                         #-CLISP 'base-char
                         :adjustable t
                         :fill-pointer 0)))
    (loop
      (setq ch (read-char stream t #\Newline t))
      (case ch
        (#\" (let ((nextch (read-char-no-hang stream t #\Newline t)))
               (when nextch
                 (unread-char nextch stream)
                 (case nextch
                   (#\Newline)
                   (#\t)
                   (#\Space)
                   (#\))
                   (t (nraw "~&Possible read-error due to ill-formed string \"~A\" ~S"
                            str *))))
               (return str)))
        (#\~ (setq ch (read-char stream t #\Newline t))
             (case ch
               (#\n (vector-push-extend #\Newline str))
               (#\t (vector-push-extend #\Tab str))
               (#\b (vector-push-extend (character   1) str))
               (#\e (vector-push-extend (character 255) str))
               (t   (vector-push-extend ch str))))
        (t (vector-push-extend ch str))))))

(set-macro-character #\" #'c-string-reader nil *indexstyle-readtable*)

#|
(let ((x #\Null))
  (loop for i from 1 to 255
        do (progn (print (character i))
                  (when (char>= x (character i))
                    (print "Whee!"))
                  (setq x (character i)))))
|#
;; line 254 "intface.nw"
(defmacro define-alphabet (&whole whole &optional name string-list)
  (cond
;; line 239 "intface.nw"
((null name)
 (error "missing argument <name> in `~S' !" whole))
((not (or (symbolp name) (stringp name)))
 (error "~S is not a symbol or a string in `~S' !" name whole))
;; line 256 "intface.nw"
        ((not (listp string-list))
           (error "missing argument <string-list> !"))
        ((not (list-of-strings-p string-list))
           (error "~S is not a list of strings" string-list))
        (t `(LET ((NAME (STRINGIFY ',name)))
             (WHEN (LOOKUP-BASETYPE *indexstyle* NAME)
               (NRAW "redefining alphabet `~S'" NAME))
             (ADD *indexstyle* (MAKE-ALPHABET NAME ',string-list))))))

(defmacro define-alphabet* (&whole whole &optional name string-list)
  (cond
;; line 239 "intface.nw"
((null name)
 (error "missing argument <name> in `~S' !" whole))
((not (or (symbolp name) (stringp name)))
 (error "~S is not a symbol or a string in `~S' !" name whole))
;; line 267 "intface.nw"
        ((not (listp string-list))
           (error "missing argument <string-list> !"))
        (t (let ((scar (car string-list)))
             (if (and (symbolp scar) (fboundp scar))
                 `(LET ((NAME (STRINGIFY ',name))
                        (STRING-LIST ,string-list)) #| evaluates string-list |#
                   (UNLESS (LIST-OF-STRINGS-P STRING-LIST)
                     (ERROR "~S is not a list of strings" STRING-LIST))
                   (WHEN (LOOKUP-BASETYPE *indexstyle* NAME)
                     (NRAW "redefining alphabet `~S'" NAME))
                   (ADD *indexstyle* (MAKE-ALPHABET NAME STRING-LIST))))))))
;; line 284 "intface.nw"
(defmacro define-enumeration (&whole
                              whole
                              &optional
                              name prefix-match-func base-alphabet)
  (cond
;; line 239 "intface.nw"
((null name)
 (error "missing argument <name> in `~S' !" whole))
((not (or (symbolp name) (stringp name)))
 (error "~S is not a symbol or a string in `~S' !" name whole))
;; line 289 "intface.nw"
        ((null prefix-match-func)
           (error "missing argument <prefix-match-function> !"))
        (t (let* ((name   (stringify name))
                  (symbol (make-symbol
                           (concatenate 'string "ENUMERATION-" name))))
             `(LET () #| PROGN instead of LET () yields a runtime error !? |#
               (IF (LOOKUP-BASETYPE *indexstyle* ,name)
                   (NRAW "redefining alphabet `~S'" ,name)
                   (PROGN
                     (DEFCLASS ,symbol (ENUMERATION) ())
                     (ADD *indexstyle*
                          (MAKE-ENUMERATION ',symbol ,name ,base-alphabet))))
               (DEFMETHOD PREFIX-MATCH ((STR STRING) (ENUM ,symbol))
                 (FUNCALL ,prefix-match-func STR)))))))
;; line 312 "intface.nw"
(defmacro define-location-class (&whole whole &rest args)
  (destructuring-switch-bind (name
                              layer-list
                              &key
                              (min-range-length *default-minimum-range-length*)
                              (hierdepth 0) ;no hierarchies are to be formed
                              &switch
                              (var :var))
      args
    (cond
      ((null name)
         (error "missing argument <name> in~%~S" whole))
      ((null layer-list)
         (error "missing argument <layer-list> in~%~S" whole))
      ;;((not (list-of-strings-p layer-list))
      ;;  (error "~S is not a list of strings in~%~S" layer-list whole))
      ((not (numberp hierdepth))
         (error "~S is not a number! in~%~S" hierdepth whole))
      ((not (or (numberp   min-range-length)
                (eql 'none min-range-length)))
         (error "~S must be a number or the keyword `none' in~%~S"
                min-range-length whole))
      (t (when (eql 'none min-range-length)
           (setq min-range-length 0))
         `(LET ((NAME (STRINGIFY ',name))
                (LAYERS (BUILD-LOCCLASS-LAYERS ',layer-list ',whole)))
           ;;(GOL T "~&define-location-class: ~S" LAYERS)
           (COND ((LOOKUP-CROSSREF-CLASS *indexstyle* NAME)
                    (OOPS "replacing cross-reference-class `~S' is not allowed !"
                          NAME))
                 (t (WHEN (LOOKUP-LOCATION-CLASS *indexstyle* NAME)
                      (NRAW "redefining location-reference-class `~S' !" NAME))
                    (ADD *indexstyle*
                         ,(if var
                              `(CHECKED-MAKE-VAR-LOCATION-CLASS NAME LAYERS
                                ,hierdepth)
                              `(CHECKED-MAKE-STANDARD-LOCATION-CLASS NAME LAYERS
                                ,min-range-length ,hierdepth))))
                 ))))))
;; line 354 "intface.nw"
(defun build-locclass-layers (layers whole)
  (let ((res-list '()))
    (loop
      ;;(gol t "~&build-locclass-layers: ~S" layers)
      (when (endp layers) (return (nreverse res-list)))
      (cond ((eql :sep (car layers))
               (setq layers (cdr layers))
               (if (endp layers)
                   (error "Reached end of list in~%~S" whole)
                   (push (make-loccls-separator (stringify (car layers)))
                         res-list)))
            (t (let* ((layer (stringify (car layers)))
                      (basetype (lookup-basetype *indexstyle* layer)))
                 (if basetype
                     (push (make-loccls-layer basetype) res-list)
                     (error "Unknown basetype ~S in~%~S" layer whole)))))
      (setq layers (cdr layers)))))
;; line 377 "intface.nw"
(defmacro define-crossref-class (&whole whole &rest args)
  (destructuring-switch-bind (name
                              &switch (verified :unverified))
      args
    (cond
;; line 239 "intface.nw"
((null name)
 (error "missing argument <name> in `~S' !" whole))
((not (or (symbolp name) (stringp name)))
 (error "~S is not a symbol or a string in `~S' !" name whole))
;; line 382 "intface.nw"
      (t `(LET ((NAME (STRINGIFY ',name)))
           (cond ((LOOKUP-LOCATION-CLASS *indexstyle* NAME)
                    (OOPS "replacing location-reference-class `~S' is not allowed !"
                          NAME))
                 (t (WHEN (LOOKUP-CROSSREF-CLASS *indexstyle* NAME)
                      (NRAW "redefining crossref-location-class `~S'" NAME))
                    (ADD *indexstyle*
                         ,(if verified
                              `(MAKE-UNVERIFIED-CROSSREF-LOCATION-CLASS NAME)
                              `(MAKE-VERIFIED-CROSSREF-LOCATION-CLASS NAME))))))))))
;; line 398 "intface.nw"
(defmacro define-location-class-order (olist)
  (cond ((not (listp olist))
           (error "missing argument <list> !"))
        ((not (list-of-strings-p olist))
           (error "~S is not a list of strings" olist))
        (t `(LET ((CTR 1))
             (MAPC #'(LAMBDA (NAME)
                       (LET* ((NEW-NAME (STRINGIFY NAME))
                              (LOCCLS
                               (CDR (LOOKUP-LOCATION-CLASS *indexstyle*
                                                           NEW-NAME))))
                         (INCF CTR)
                         (COND (LOCCLS (SET-ORDNUM CTR LOCCLS))
                               (t (OOPS "unknown location-class `~S'"
                                        NEW-NAME)))))
              ',olist)))))
;; line 423 "intface.nw"
(defmacro define-attributes (&whole whole &optional attr-list)
  (cond ((null attr-list)
           (error "missing argument <attribute-list> in~&~S" whole))
        (t (let* ((wf-attr-list (make-well-formed-list attr-list))
                  (plain-list (apply #'concatenate 'list wf-attr-list))
                  )
             `(PROGN
               (MAPCAR
                #'(LAMBDA (CATATTR)
                    (IF (LOOKUP-CATATTR *indexstyle* CATATTR)
                        (NRAW "ignoring redefinition of attribute ~S in~&~S"
                              CATATTR ',whole)
                        (ADD *indexstyle*
                             (MAKE-CATEGORY-ATTRIBUTE CATATTR))))
                ',plain-list)
               (INITIALIZE-CATEGORY-ATTRIBUTES ',wf-attr-list *indexstyle*))
             ))))
;; line 488 "intface.nw"
#+:ORDRULES
(defmacro merge-rule (&whole whole &rest args)
  (destructuring-switch-bind (pattern
                              replacement
                              &switch
                              (again           :again)
                              (string          :string)
                              (extended-regexp :eregexp)
                              (basic-regexp    :bregexp))
      args
    (cond ((null pattern)
             (error "missing argument <pattern> !"))
          ((or (and string extended-regexp) (and string basic-regexp)
               (and extended-regexp basic-regexp))
             (error "~&Only one of (:string :bregexp :eregexp) allowed in:~&~S !"
                    whole))
          ((null replacement)
             (error "~&Missing argument <replacement> in:~&~S!" whole))
          (t `(PROGN
               (UNLESS
                   (ZEROP
                    (ORDRULES:ADD-KEYWORD-MERGE-RULE ,pattern ,replacement
                                                     ,(if again 1 0)
                                                     ,(cond (string 1)
                                                            (basic-regexp 2)
                                                            (extended-regexp 3)
                                                            (t 0))))
                 (OOPS "~&Wrong regular expression ~S in:~%~S." ',pattern ',whole))
               (FLUSH-ORDRULES-MESSAGE-BUFFER))))))

#-:ORDRULES
(defmacro merge-rule (&rest args)
  (declare (ignore args))
  (oops "merge-rule not supported! ignoring definition"))
;; line 525 "intface.nw"
#+:ORDRULES
(defparameter *sort-rule-orientations*
  '(forward forward forward forward
    forward forward forward forward))

#+:ORDRULES
(defmacro define-sort-rule-orientations (&whole whole &rest args)
  (destructuring-switch-bind (&optional
                              (orientations *sort-rule-orientations*))
      args
    (unless (every #'(lambda (run)
                       (member run '(forward backward)))
                   orientations)
      (error "~&Elements of ~S must be one of {forward,backward}!"
        orientations))
    `(PROGN
      (SETQ *SORT-RULE-ORIENTATIONS* ',orientations)
      (ORDRULES:INITIALIZE (LENGTH *SORT-RULE-ORIENTATIONS*))
      (FLUSH-ORDRULES-MESSAGE-BUFFER))))

#+:ORDRULES
(defmacro define-rule-set (&whole whole &rest args)
  (destructuring-bind (&optional
                       name
                       &key
                       inherit-from
                       rules)
      args
    (cond
;; line 239 "intface.nw"
((null name)
 (error "missing argument <name> in `~S' !" whole))
((not (or (symbolp name) (stringp name)))
 (error "~S is not a symbol or a string in `~S' !" name whole))
;; line 554 "intface.nw"
          ((not (listp rules))
             (error "missing argument <rules-list> !"))
          (t `(LET ((RS (MAKE-RULE-SET ',name ',inherit-from ',rules)))
               (MAPC #'(LAMBDA (INH-NAME)
                         (INHERIT-RULE-SET RS (LOOKUP-RULE-SET *INDEXSTYLE*
                                                               INH-NAME)))
                ',inherit-from)
               (ADD-RULE-SET *INDEXSTYLE* RS))))))

#-:ORDRULES
(defmacro define-rule-set (&rest args)
  (declare (ignore args))
  (oops "define-rule-sets not supported! ignoring definition"))

#+:ORDRULES
(defmacro use-rule-set (&whole whole &rest args)
  ;; FIXME: if we use destructuring-switch-bind-here an error occurs
  (destructuring-bind (&key
                       run
                       rule-set)
      args
    (cond ((not (integerp run))
             (error "incorrect argument <run> !"))
          ((not rule-set)
             (error "missing argument <rule-set> !"))
          ((not (or (listp rule-set)
                    (stringp rule-set)))
             (error "wrong argument to <rule-set> !"))
          (t `(INSTANTIATE-RULE-SET ,run ,rule-set)))))

#-:ORDRULES
(defmacro use-rule-set (&rest args)
  (declare (ignore args))
  (oops "use-rule-sets not supported! ignoring definition"))

#+:ORDRULES
(defmacro sort-rule (&whole whole &rest args)
  (destructuring-switch-bind (pattern
                              replacement
                              &key
                              (run 0)
                              &switch
                              (again           :again)
                              (string          :string)
                              (extended-regexp :eregexp)
                              (basic-regexp    :bregexp))
      args
    (cond ((null pattern)
             (error "missing argument <pattern> !"))
          ((or (< run 0) (>= run (length *sort-rule-orientations*)))
             (error "~&Argument of :run must be in the interval [0..~A]!"
                    (length *sort-rule-orientations*)))
          ((or (and string extended-regexp) (and string basic-regexp)
               (and extended-regexp basic-regexp))
             (error "~&Only one of (:string :bregexp :eregexp) allowed in:~&~S !"
                    whole))
          ((null replacement)
             (error "missing argument <replacement> !"))
          (t `(PROGN
               (UNLESS
                   (ZEROP
                    (ORDRULES:ADD-KEYWORD-SORT-RULE ,run ,pattern ,replacement
                                                    ,(if again 1 0)
                                                    ,(cond (string 1)
                                                           (basic-regexp 2)
                                                           (extended-regexp 3)
                                                           (t 0))))
                 (OOPS "~&Wrong regular expression ~S in:~%~S." ',pattern ',whole))
               (FLUSH-ORDRULES-MESSAGE-BUFFER))))))

#-:ORDRULES
(defmacro define-sort-rule-orientations (&rest args)
  (declare (ignore args))
  (oops "define-sort-rule-orientations not supported! ignoring definition"))

#-:ORDRULES
(defmacro sort-rule (&rest args)
  (declare (ignore args))
  (oops "sort-rule not supported! ignoring definition"))

(defun flush-ordrules-message-buffer ()
  #+:ORDRULES
  (when (and *mappings-trace* ordrules::*message-logging*)
    (gol t "~A" ordrules::*message-buffer*)
    (setq ordrules::*message-buffer-ptr* 0)))
;; line 696 "intface.nw"
(defmacro define-letter-group
    (&whole whole name &key prefixes before after)
  (cond
;; line 239 "intface.nw"
((null name)
 (error "missing argument <name> in `~S' !" whole))
((not (or (symbolp name) (stringp name)))
 (error "~S is not a symbol or a string in `~S' !" name whole))
;; line 699 "intface.nw"
        ((and before
              (not (lookup-letter-group-definition *indexstyle* before)))
           (error "~S does not name a letter group in~%~S" before whole))
        ((and after
              (not (lookup-letter-group-definition *indexstyle* after)))
           (error "~S does not name a letter group in~%~S" after whole))
        ((not (list-of-strings-p prefixes))
           (error "argument <prefixes> is not a list of strings in~%~S"
                  whole))
        (t `(LET ()
             (ADD-LETTER-GROUPS *INDEXSTYLE*
              ,name ',(or prefixes (list name))
              :BEFORE ,before :AFTER ,after)))))
;; line 718 "intface.nw"
(defmacro define-letter-groups (&whole whole &optional letter-groups)
  (cond ((not (list-of-strings-p letter-groups))
           (error "~S is not a list of strings in~%~S" letter-groups whole))
        (t `(LET ()
             (ADD-LETTER-GROUPS *INDEXSTYLE*
              ,(car letter-groups) ',(list (car letter-groups)))
             ,@(let ((last (car letter-groups)))
                    (mapcar #'(lambda (letter-group)
                                (prog1
                                    `(ADD-LETTER-GROUPS *INDEXSTYLE*
                                      ,letter-group ',(list letter-group)
                                      :AFTER ,last)
                                  (setq last letter-group)))
                            (cdr letter-groups)))))))
;; line 650 "intface.nw"
(defmacro merge-to (&whole whole &rest args)
  (destructuring-switch-bind (from to &switch drop)
      args
    (let ((from-attr (lookup-catattr *indexstyle* from))
          (to-attr   (lookup-catattr *indexstyle* to)))
      (cond ((not from-attr)
               (nraw "`~S' is not a known attribute in:~&~A" from whole))
            ((not to-attr)
               (nraw "`~S' is not a known attribute in:~&~A" to whole))
            (t (if drop
                   `(ADD-DROP-IF-MERGED-RULE *INDEXSTYLE*
                     ',from-attr ',to-attr)
                   `(ADD-MERGE-RULE *INDEXSTYLE*
                     ',from-attr ',to-attr)))))))
;; line 740 "intface.nw"
;;; we remove the inherited symbol and establish a new one
(eval-when (compile load eval)
  (shadow 'require))

(defmacro require (&rest args)
  (cond ((null args)
           (error "missing argument <filename> !"))
        ((not (stringp (car args)))
           (error "(require ~S): expected <filename> !" (car args)))
        (t `(LET ((FILENAME (STRINGIFY ',(car args))))
             (DO-REQUIRE FILENAME)))))

(defun do-require (filename)
  (let ((file (find-file filename)))
    (unless (member file *included-files* :test #'equalp)
      (push file *included-files*)
      (info "~&Loading module ~S..." filename)
      (watched-load file :echo t)
      (info "~&Finished loading module ~S.~%" filename))))

#|
(defun do-require (filename)
  (let ((file (find-file filename)))
    (unless (member file *included-files* :test #'equalp)
      (push file *included-files*)
      (info "~&Loading module ~S..." filename)
      (let ((*standard-output* (make-string-output-stream)))
        (handler-case
            (load file :verbose nil :echo t)
;         (stream-error (cond)
;                       (step
;                        (progn
;                          (oops*
;                            (simple-condition-format-string cond)
;                            (simple-condition-format-arguments cond))
;                          (exit))
;                        )
;                       )
          (error (condition)
                 (info "~&~%~A~%" ";;;;;;;;;;;;;;;;;;;;;;;;")
                 (info "~A~%"     ";; ERROR SECTION START")
                 (info "~%~A~%" (get-output-stream-string *standard-output*))
                 (info "~%~A~%"   ";; ERROR SECTION END")
                 (info "~A~%~%"   ";;;;;;;;;;;;;;;;;;;;;;;;")
                 (oops* (simple-condition-format-string    condition)
                        (simple-condition-format-arguments condition))
                 (error-exit))
          )
        )
      (info "~&Finished loading module ~S.~%" filename))))
|#
;; line 802 "intface.nw"
(defun find-file (filename)
  (let ((file (parse-namestring filename)))
    (when (equal (file-namestring file) "")
      (error "~S is not a valid filename !" filename))
    (let ((found (some #'(lambda (path)
                           (and (probe-file (append-pathnames path file))))
                       *load-paths*)))
      (or found (error "Could not find file ~S !" filename)))))
;; line 813 "intface.nw"
(defvar *wl-fmt* "~&~%Error in line ~S:~%~A~%")
(defun watched-load (filename
                     &key
                     (print *load-print*)
                     (if-does-not-exist t)
                     echo)
  (let ((stream (open (setq filename (pathname filename))
                      :direction
                      #+CLISP :input-immutable
                      #-CLISP :input
                      :element-type
                      #+CLISP 'string-char
                      #-CLISP 'base-char
                      :if-does-not-exist nil))
        (lineno 1))
    (if stream
        (let* ((load-stream (make-string-output-stream))
               (input-stream (if echo
                                 (make-echo-stream stream load-stream)
                                 stream
                                 ))
               (*load-pathname* (if (pathnamep filename) filename nil))
               (*load-truename* (if (pathnamep filename) (truename filename) nil))
               (*package* *package*)    ; *PACKAGE* binden
               (*readtable* *readtable*) ; *READTABLE* binden
               (end-of-file "EOF"))     ; einmaliges Objekt
          ;;(setq sys::*load-input-stream* input-stream)
          (block nil
            (unwind-protect
                 (tagbody weiter
                    (let* ((obj
                            (handler-case (read input-stream nil end-of-file)
                              (error (cond)
                                (when echo
                                  (let* ((str (get-output-stream-string load-stream))
                                         (cnt (count #\Newline str)))
                                    (info *wl-fmt* (+ cnt lineno) str)
                                    (oops* (simple-condition-format-string cond)
                                           (simple-condition-format-arguments cond))
                                    (error-exit))))))
                           (str (get-output-stream-string load-stream))
                           (cnt (count #\Newline str)))
                      (incf lineno cnt)
                      (when (eql obj end-of-file)
                        (return-from nil))
                      (setq obj
                            (multiple-value-list
                                (cond ((compiled-function-p obj) (funcall obj))
                                      ;;(compiling (funcall (compile-form obj nil nil nil nil nil)))
                                      (t (handler-case (eval obj)
                                           (error (cond)
                                             (info *wl-fmt* lineno str)
                                             (oops* (simple-condition-format-string cond)
                                                    (simple-condition-format-arguments cond))
                                             (error-exit)))
                                         (get-output-stream-string load-stream)
                                         ))))
                      (when print (when obj (print (first obj))))
                      )
                    (go weiter)
                    )
              (close stream) (close input-stream)
              ) )
          t)
        (if if-does-not-exist
            (error "A file with name ~A does not exist" filename)
            nil)
        ) ))
;; line 891 "intface.nw"
(defmacro searchpath (&rest args)
  (cond ((null args)
           (error "missing argument <pathlist> !"))
        ((stringp (car args))
           `(SET-SEARCHPATH-BY-STRING ,(car args)))
        ((listp args)
           `(SET-SEARCHPATH ',(car args)))))

(defun set-searchpath-by-string (searchpath-str)
  (set-searchpath (string-to-searchlist searchpath-str)))
;; line 913 "intface.nw"
(defun string-to-searchlist (str)
  (let ((paths '())
        pos)
    (nreverse
     (loop (when (equalp str "")
             (return (push :default paths)))
           (setq pos (position #+UNIX #\:
                               #+OS/2 #\;
                               str))
           (if pos
               (progn
                 (push (subseq str 0 pos) paths)
                 (setq str (subseq str (1+ pos))))
               (return (push str paths)))))))

(defun set-searchpath (path-list)
  (setq *load-paths*
        (apply #'nconc
               (mapcar
                #'(lambda (elt)
                    (cond ((stringp elt)
                             (list (make-real-pathname elt)))
                          ((eq elt :default)
                             *default-load-paths*)
                          ((eq elt :last)
                             *load-paths*)
                          (t (oops "~&searchpath: invalid argument ~S in~%~S"
                                   elt path-list))))
                path-list))))
;; line 954 "intface.nw"
#+CLISP
(defun make-real-pathname (pathname-str)
  (let* ((pn     (pathname pathname-str))
         (fname  (file-namestring pn)))
    (if (string/= fname "")
        (make-pathname :device (pathname-device pn)
                       :directory (append (or (pathname-directory pn)
					      '(:relative))
                                          (list fname)))
        pn)))
;; line 966 "intface.nw"
#-CLISP
(defun make-real-pathname (pathname-str)
  (let ((pn (parse-namestring
             (if (eql (elt pathname-str (1- (length pathname-str))) #\/)
                 pathname-str
                 (concatenate 'string pathname-str "/")))))
    (if (pathname-directory pn)
        pn
        (make-pathname :directory (list :relative (pathname-name pn))))))
;; line 986 "intface.nw"
(defun append-pathnames (pn-dir pn-sub)
  (let ((dir-dir (pathname-directory pn-dir))
        (dir-sub (pathname-directory pn-sub)))
    (cond ((eq :absolute (car dir-sub)) pn-sub)
          (t (make-pathname :device (pathname-device pn-dir)
                            :directory (append dir-dir (cdr dir-sub))
                            :name (pathname-name pn-sub)
                            :type (pathname-type pn-sub))))))

;; line 62 "intface.nw"
(defparameter *idxstyle-user-interface-definitions*
  '(
    *default-minimum-range-length*
    *included-files*
    *indexstyle-readtable*
    define-alphabet
    define-alphabet*
    define-attributes
    define-crossref-class
    define-enumeration
    define-letter-group
    define-letter-groups
    define-location-class
    define-location-class-order
    define-rule-set
    define-sort-rule-orientations
    forward backward
    info
    merge-rule
    merge-to
    require
    searchpath
    sort-rule
    use-rule-set
    *indexstyle*
    ))

;; line 1168 "intface.nw"
(eval-when (compile load eval)

;; line 91 "intface.nw"
(export '(*indexstyle*
          *indexstyle-readtable*
          do-require
          set-searchpath-by-string
          *sort-rule-orientations*
          forward backward
          *idxstyle-user-interface-definitions*
          ))
;; line 159 "intface.nw"
(export '(stringify list-of-strings-p
          make-well-formed-list map-to-strings))
;; line 642 "intface.nw"
(export 'flush-ordrules-message-buffer)
;; line 1170 "intface.nw"
  )
;; line 557 "idxrule.nw"
;; $Id: idxrule.nw,v 1.10 1997/03/26 16:18:19 kehr Exp $

;; line 323 "idxrule.nw"
(defclass relation ()
    ((rel-sets :accessor get-rel-sets
               :initform '() )
     (rel-hash :accessor get-rel-hash
               :initform (make-hash-table :test #'equal))))

(defun make-relation ()
  (make-instance 'relation))
;; line 344 "idxrule.nw"
(defmethod rel-insert ((rel relation) x y)
  (let* ((rel-sets (get-rel-sets rel))
         (x-node (assoc x rel-sets))
         (y-node (assoc y rel-sets)))
    (cond ((null x-node) (setf (get-rel-sets rel) (cons (list x y) rel-sets)))
          ((member y (cdr x-node)))
          (t (rplacd x-node (cons y (cdr x-node)))))
    (when (and (null y-node) (not (eql x y)))
      (setf (get-rel-sets rel) (cons (list y) (get-rel-sets rel)))))
  rel)

(defmethod rel-simple-insert ((rel relation) x)
  (let* ((rel-sets (get-rel-sets rel))
         (x-node (assoc x rel-sets)))
    (unless x-node (setf (get-rel-sets rel) (cons (list x) rel-sets))))
  rel)
;; line 366 "idxrule.nw"
(defmethod rel-merge ((rel-1 relation) x)
  (declare (ignore x))
  rel-1)

(defmethod rel-merge ((rel-1 relation) (rel-2 relation))
  (mapc #'(lambda (r-2)
            (let ((r-1 (assoc (car r-2) (get-rel-sets rel-1))))
              (cond ((null r-1)
                       (setf (get-rel-sets rel-1)
                             (cons r-2 (get-rel-sets rel-1))))
                    (t (rplacd r-1 (union (cdr r-1) (cdr r-2)))))))
        (get-rel-sets rel-2))
  rel-1)
;; line 387 "idxrule.nw"
(defmacro relation-set (rel x)
  `(CDR (ASSOC ,x (SLOT-VALUE ,rel 'REL-SETS))))
;; line 408 "idxrule.nw"
(defmethod make-ready ((rel relation))
  (let ((ht (get-rel-hash rel)))
    (mapc #'(lambda (node)
              (mapc #'(lambda (succ-node)
                        (setf (gethash (cons (car node) succ-node) ht)
                              t))
                    (cdr node)))
          (get-rel-sets rel)))
  rel)
;; line 423 "idxrule.nw"
(defmacro relation-p (rel x y)
  `(GETHASH (CONS ,x ,y) (SLOT-VALUE ,rel 'REL-HASH)))
;; line 439 "idxrule.nw"
(defun print-relation (rel-sets stream printfunc
                                &key open close headsep listsep)
  (mapc #'(lambda (from)
            (when open (format stream open))
            (write (funcall printfunc (car from)) :stream stream)
            (when headsep (format stream headsep))
            (mapc #'(lambda (to)
                      (write (funcall printfunc to) :stream stream)
                      (when listsep (format stream listsep)))
                  (cdr from))
            (when close (format stream close)))
        rel-sets))
;; line 467 "idxrule.nw"
(defmethod topsort ((rel relation))
  (let ((rel-set (copy-tree (get-rel-sets rel)))
        (topsort-list '()))
    (loop
      (let ((zero-indeg (find-if #'(lambda (x) (null (cdr x))) rel-set)))
        (when (null zero-indeg) (return))
        (let ((zero-indeg-elt (car zero-indeg)))
          (setq topsort-list (cons zero-indeg-elt topsort-list))
          (setq rel-set (delete zero-indeg rel-set :test #'equal))
          (mapc #'(lambda (x)
                    (rplacd x (delete zero-indeg-elt (cdr x) :test #'equal)))
                rel-set)))
      )
    (if (null rel-set)
        (values topsort-list t)
        (values nil rel-set))))
;; line 494 "idxrule.nw"
(defmethod transform-relation ((rel relation) transform-func)
  (let ((new-rel (make-relation)))
    (mapc #'(lambda (x)
              (let ((transformed-x (funcall transform-func (car x))))
                (mapc #'(lambda (y)
                          (rel-insert new-rel
                                      transformed-x
                                      (funcall transform-func y)))
                      (cdr x))))
          (get-rel-sets rel))
    new-rel))
;; line 511 "idxrule.nw"
(defmethod remove-reflexivity ((rel relation))
  (mapc #'(lambda (x)
            (rplacd x (delete (car x) (cdr x) :test #'equal)))
        (get-rel-sets rel))
  rel)
;; line 529 "idxrule.nw"
(defmethod transitive-hull ((rel relation))
  (setf (get-rel-sets rel)
        (let ((rel-sets (get-rel-sets rel)))
          (mapc #'(lambda (j)
                    (mapc #'(lambda (i)
                              (when (member (car j) (cdr i))
                                (mapc #'(lambda (k)
                                          (when (and
                                                 (member (car k) (cdr j))
                                                 (not (member (car k)
                                                              (cdr i))))
                                            (rplacd (last i)
                                                    (list (car k)))))
                                      rel-sets)))
                          rel-sets))
                rel-sets)))
  rel)
;; line 61 "idxrule.nw"
(defclass index-rule ()
    ())

(defclass relation-rule (index-rule relation)
    ())
;; line 88 "idxrule.nw"
(defclass merge-rule (relation-rule)
    ())

(defun make-merge-rule ()
  (make-instance 'merge-rule))
;; line 117 "idxrule.nw"
(defclass drop-if-merged-rule (relation-rule)
    ())

(defun make-drop-if-merged-rule ()
  (make-instance 'drop-if-merged-rule))
;; line 278 "idxrule.nw"
(defclass substitution-rule (relation-rule)
    ())

(defun make-substitution-rule ()
  (make-instance 'substitution-rule))
;; line 164 "idxrule.nw"
(defclass catattr-groups (index-rule)
    ((attribute-list  :reader get-attribute-list
                      :writer set-attribute-list
                      :initform nil)
     (attribute-table :reader get-attribute-table
                      :initform (make-hash-table :test #'equal
                                                 :size 16))))

(defun make-catattr-groups ()
  (make-instance 'catattr-groups))

(defmethod add ((catattr-grp catattr-groups)
                (catattr     category-attribute))
  (setf (gethash (get-name catattr) (get-attribute-table catattr-grp))
        catattr))

(defmacro lookup-catattr-name (catattr-grp catattr-name)
  `(GETHASH ,catattr-name (SLOT-VALUE ,catattr-grp 'ATTRIBUTE-TABLE)))
;; line 217 "idxrule.nw"
(defun initialize-category-attributes (attribute-list idxcls)
  (let ((catattr-grps    (get-cat-attrs idxcls))
        (impl-subst-rule (get-implicit-subst-rules idxcls)))
    (set-attribute-list attribute-list catattr-grps)
    (let ((catattr-grp-counter 0)
          (sort-ordnum-counter 0))
      (mapc
       #'(lambda (sublist)
           (incf catattr-grp-counter)
           (let ((last-in-group (lookup-catattr-name catattr-grps
                                                     (car (last sublist))))
                 (prev-catattr nil))
             (mapc
              #'(lambda (catattr)
                  (cond ((stringp catattr)
                           (let ((ca (lookup-catattr-name catattr-grps
                                                          catattr)))
                             (incf sort-ordnum-counter)
                             (set-sort-ordnum        sort-ordnum-counter ca)
                             (set-catattr-grp-ordnum catattr-grp-counter ca)
                             (set-last-in-group      last-in-group       ca)
                             (when prev-catattr
                               (rel-insert impl-subst-rule
                                           (lookup-catattr-name catattr-grps
                                                                prev-catattr)
                                           (lookup-catattr-name catattr-grps
                                                                catattr)))
                             (setq prev-catattr catattr)))
                        (t (error "~A  is not a string" catattr))))
              sublist)))
       attribute-list))
    catattr-grps))

;; line 566 "idxrule.nw"
(eval-when (compile load eval)

;; line 69 "idxrule.nw"
(export '(index-rule relation-rule))
;; line 96 "idxrule.nw"
(export '(merge-rule make-merge-rule))
;; line 125 "idxrule.nw"
(export '(drop-if-merged-rule make-drop-if-merged-rule))
;; line 185 "idxrule.nw"
(export '(catattr-groups make-catattr-groups lookup-catattr-name))
;; line 252 "idxrule.nw"
(export '(initialize-category-attributes catattr-single catattr-mixed))
;; line 286 "idxrule.nw"
(export '(substitution-rule make-substitution-rule))
;; line 428 "idxrule.nw"
(export '(relation make-relation get-rel-sets
          rel-insert rel-merge make-ready
          relation-set relation-p))
;; line 549 "idxrule.nw"
(export '(topsort transform-relation remove-reflexivity transitive-hull))
;; line 568 "idxrule.nw"
  )
;; line 873 "idxclass.nw"
;; $Id: idxclass.nw,v 1.20 1997/03/26 16:18:16 kehr Exp $
;;

;; line 129 "idxclass.nw"
(defparameter *locref-cache-size*        1000)
(defparameter *locref-cache-rehash-size*    2)
(defparameter *locref-cache-hits*           0)
(defparameter *locref-cache-misses*         0)
;; line 80 "idxclass.nw"
(defclass indexclass ()
    ((name                 :initarg :name :type string)
     (basetypes            :accessor get-basetypes
                           :initform (make-hash-table :test #'equal :size 10))
     (cat-attrs            :accessor get-cat-attrs
                           :initform (make-catattr-groups))
     (locref-classes       :accessor get-locref-classes
                           :initform '() :type list)
     (xref-classes         :accessor get-xref-classes
                           :initform '() :type list)
     (letter-groups        :reader get-letter-groups
                           :initform (make-letter-group-manager))
     (partial-order-dict   :reader get-partial-order-dict
                           :initform (make-partial-order-dict))
     (letter-dict          :reader get-letter-dict
                           :initform (make-letter-dict))
     (rule-sets            :reader get-rule-sets
                           :initform (make-hash-table :test #'equal :size 20))

;; line 136 "idxclass.nw"
     (locref-cache :initform (initialize-locref-cache))
;; line 99 "idxclass.nw"
     ;;     (succ-table           :accessor get-succ-table
     ;;                           :initform (make-hash-table))

;; line 219 "idxclass.nw"
     (merge-rules          :reader get-merge-rules
                           :initform (make-merge-rule))
     (drop-if-merged-rules :reader get-drop-if-merged-rules
                           :initform (make-drop-if-merged-rule))
;;     (merge-rule-topsort   :reader get-merge-rule-topsort
;;                           :writer set-merge-rule-topsort
;;                           :initform '())


;; line 724 "idxclass.nw"
     (merge-drop-hook  :reader get-merge-drop-hook
                       :writer set-merge-drop-hook
                       :initform #'set-state-deleted)

;; line 229 "idxclass.nw"
     (implicit-subst-rules :reader get-implicit-subst-rules
                           :initform (make-substitution-rule))
     (explicit-subst-rules :reader get-explicit-subst-rules
                           :writer set-explicit-subst-rules
                           :initform (make-substitution-rule))

;; line 776 "idxclass.nw"
     (implicit-subst-hook  :reader get-implicit-subst-hook
                           :writer set-implicit-subst-hook
                           :initform #'transitive-hull)
     (explicit-subst-hook  :reader get-explicit-subst-hook
                           :writer set-explicit-subst-hook
                           :initform #'identity)
     (global-subst-hook    :reader get-global-subst-hook
                           :writer set-global-subst-hook
                           :initform #'identity)
     (substitution-subst-hook :reader get-substitution-subst-hook
                              :writer set-substitution-subst-hook
                              :initform #'null)
;; line 102 "idxclass.nw"
     ))

(defun make-indexclass (name)
  (make-instance 'indexclass :name name))
;; line 253 "idxclass.nw"
(defparameter *default-letter-group-definition* "default")

(defclass letter-group-definition ()
    ((name    :initarg :name    :type string)
     (ordnum  :initarg :ordnum  :type number)))

(defun make-letter-group-definition (name)
  (make-instance 'letter-group-definition :name name :ordnum 0))

(defclass letter-group-manager ()
    ((prefixes      :accessor get-prefixes
                    :initform (make-hash-table :test #'equal))
     (letter-groups :accessor get-letter-groups
                    :initform (make-hash-table :test #'equal))
     (sort-relation :accessor get-sort-relation
                    :initform (make-relation))
     (lookup-list   :accessor get-lookup-list  :initform '())))

(defun make-letter-group-manager ()
  (let* ((lgm (make-instance 'letter-group-manager))
         (letter-groups (get-letter-groups lgm))
         (default-group (make-letter-group-definition
                         *default-letter-group-definition*)))
    (setf (gethash *default-letter-group-definition* letter-groups)
          default-group)
    (rel-simple-insert (get-sort-relation lgm) default-group)
    lgm))
;; line 295 "idxclass.nw"
(defun make-lookup-list (lgm)
  (setf (get-lookup-list lgm)
        (let ((lookup-list '()))
          (maphash #'(lambda (key elt)
                       (push (cons key elt) lookup-list))
                   (get-prefixes lgm))
          (sort lookup-list #'prefix<))))

(defun prefix< (x y)
  (let ((cx (car x))
        (cy (car y)))
    (let ((same-prefix (string/= cx cy)))
      (cond ((null same-prefix))
            ((> same-prefix 0)
               (and (= same-prefix (length (car y)))))
            (t (string< cx cy))))))
;; line 326 "idxclass.nw"
(defun add-letter-group-to-manager (lgm name prefix &key before after)
  (let* ((prefixes      (get-prefixes      lgm))
         (letter-groups (get-letter-groups lgm))
         (letter-group  (gethash name letter-groups)))
    (unless letter-group;; this letter group is unknown -- create one!
      (setq letter-group (make-letter-group-definition name))
      (setf (gethash name letter-groups) letter-group)
      (rel-simple-insert (get-sort-relation lgm) letter-group))
    (let ((current-binding (gethash prefix prefixes)))
      (and current-binding
           (not (equal name (get-name current-binding)))
           (warn "define-letter-group: prefix ~S now maps to letter group ~S"
                 prefix name)))
    (setf (gethash prefix prefixes) letter-group)
    (when before
      (rel-insert (get-sort-relation lgm)
                  letter-group
                  (lookup-letter-group-definition *indexstyle* before)))
    (when after
      (rel-insert (get-sort-relation lgm)
                  (lookup-letter-group-definition *indexstyle* after)
                  letter-group)))
  lgm)

(defmethod lookup-letter-group-definition ((idxcls indexclass) (letter string))
  (gethash letter (get-letter-groups (get-letter-groups idxcls))))
;; line 360 "idxclass.nw"
(defmethod make-ready ((lgm letter-group-manager))
  (make-lookup-list lgm)
  (let ((sort-relation  (get-sort-relation lgm)))
    (multiple-value-bind (topsorted-list remaining-relation)
        (topsort sort-relation)
      (if topsorted-list
          (let ((ctr 0))
            (mapc #'(lambda (grp-def)
                      (setf (get-ordnum grp-def) (incf ctr)))
                  topsorted-list))
          (error
           (concatenate 'string
                        "The user-defined relations for the letter-groups contains cycles!~%The part of the relation containing cycles is"
                        (with-output-to-string (s)
                          (print-relation remaining-relation s
                                          #'(lambda (lgdef)
                                              (get-name lgdef))
                                          :open "~%" :headsep " before "
                                          :listsep " "))))))))
;; line 388 "idxclass.nw"
(defmethod match-letter-group ((idxcls indexclass) (letter string))
  (let* ((lgm         (get-letter-groups idxcls))
         (lookup-list (get-lookup-list lgm))
         (match (find-if #'(lambda (prefix-cons)
                             (let* ((prefix (car prefix-cons))
                                    (match-len (string/= prefix letter)))
                               (or (not match-len) #| full match |#
                                   (= match-len    #| full match with lg |#
                                      (length prefix)))))
                         lookup-list))
         (letter-group-definition
          (if match
              (cdr match);; the corresponding letter-grp-def
              (lookup-letter-group-definition
               *indexstyle* *default-letter-group-definition*))))
    (gol t "~&Letter-group: ~S -> ~S"
         letter (get-name letter-group-definition))
    letter-group-definition))
;; line 549 "idxclass.nw"
(defclass rule-set ()
    ((name        :initarg  :name)
     (rules-list  :accessor rules-list :initarg :rules-list)
     (rules-hash  :reader   rules-hash
                  :initform (make-hash-table :test #'equal :size 32))
     ))

(defun make-rule-set (name inherit rules)
  (unless (every #'(lambda (rule)
                     (and (stringp (car  rule));; pattern
                          (stringp (cadr rule)));; replacement
                     )
                 rules)
    (error "not a valid rule-set definition!"))
  (let ((rs (make-instance 'rule-set :name name :rules-list rules)))
    (let ((rh (rules-hash rs)))
      (mapc #'(lambda (rule)
                (setf (gethash (car rule) rh) rule))
            rules)
      (mapc #'(lambda (inh-name)
                (let ((inh-rs  (lookup-rule-set *indexstyle* inh-name)))
                  (when inh-rs
                    (inherit-rule-set rs inh-rs))))
            inherit)
      rs)))

#|
(add-rule-set *indexstyle*
              (make-rule-set "foo" '() '(("foo" "bar" :again)
                                         ("baz" "bam" :string)
                                         ("1"   "3"))))

(add-rule-set *indexstyle*
              (make-rule-set "bar" '() '(("1" "bar" :again)
                                         ("2" "bam" :string))))
|#

(defmacro instantiate-rule-set (run rule-set-names)
  (let ((rs (make-rule-set "temporary rule-set" rule-set-names '())))
    (when rs
      (cons 'progn
            (mapcar #'(lambda (rule)
                        `(SORT-RULE ,@rule :RUN ,RUN))
                    (rules-list rs))))))



(defun inherit-rule-set (rs parent)
  (let ((rs-hash (rules-hash rs)))
    (mapc #'(lambda (rule)
              (let ((pattern (car rule)))
                (unless (gethash pattern rs-hash)
                  (setf (gethash pattern rs-hash) rule)
                  (setf (rules-list rs)
                        (append (rules-list rs) (list rule))))))
          (rules-list parent))
    rs))
;; line 140 "idxclass.nw"
(defun initialize-locref-cache ()
  (setq *locref-cache-hits*   0)
  (setq *locref-cache-misses* 0)
  (make-hash-table :test #'equal
                   :size        *locref-cache-size*
                   :rehash-size *locref-cache-rehash-size*))

(defmethod clear-locref-cache ((idxclass indexclass))
  (setf (get-locref-cache idxclass)
        (initialize-locref-cache)))

(defun set-locref-cache-parameters (&key (size 1000) (rehash-size 3))
  (when (< size 100) (setq size 100))
  (when (< rehash-size 1.5) (setq rehash-size 1.5))
  (setq *locref-cache-size* size)
  (setq *locref-cache-rehash-size* rehash-size))
;; line 165 "idxclass.nw"
(defmacro lookup-locref-cache (idxcls locref-string)
  `(LET ((LOCREF-LOOKUP (GETHASH ,locref-string
                                 (SLOT-VALUE ,idxcls 'LOCREF-CACHE))))
    (IF LOCREF-LOOKUP
        (PROGN
          (INCF *LOCREF-CACHE-HITS*)
          (VALUES (CAR LOCREF-LOOKUP) (CDR LOCREF-LOOKUP)))
        (PROGN
          (INCF *LOCREF-CACHE-MISSES*)
          (VALUES NIL NIL)))))

(defmethod add-locref-cache ((idxcls indexclass)
                             (locref-string string)
                             (num    number)
                             ;; the next one is typeless, since we
                             ;; also want to store the value NIL into
                             ;; it, to denote a mismatch
                             locref)
  (setf (gethash locref-string (get-locref-cache idxcls))
        (cons num locref))
  (values num locref))

(defmethod locref-statistics ((idxcls indexclass))
  (let ((ht (get-locref-cache idxcls)))
    (with-output-to-string (s)
      (format
       s "Statistics for locref-cache of indexclass ~S:~%" (get-name idxcls))
      (format
       s
       "Hash-table: size=~A, count=~A, cache-hits=~A, cache-misses=~A, hits=~4,1,,'*F%~%"
       (hash-table-size ht) (hash-table-count ht)
       *locref-cache-hits* *locref-cache-misses*
       (if (> *locref-cache-misses* 0)
           (* 100 (/ *locref-cache-hits* (+ *locref-cache-hits*
                                            *locref-cache-misses*)))
           100.0 #| produces an invalid value |#)))))
;; line 430 "idxclass.nw"
(defmethod add ((idxcls indexclass) (basetype basetype))
  (setf (gethash (get-name basetype) (get-basetypes idxcls))
        basetype)
  idxcls)

(defmethod add-alias ((idxcls indexclass) basetype alias-name)
  (let ((new-basetype (make-copy (lookup-basetype idxcls basetype)
                                 alias-name)))
    (add idxcls new-basetype)))

(defmethod add ((idxcls indexclass) (catattr category-attribute))
  (add (get-cat-attrs idxcls) catattr)
  idxcls)
;; line 446 "idxclass.nw"
(defun add-letter-groups (idxcls name prefixes &key before after)
  (let ((lgm (get-letter-groups idxcls)))
    (mapc #'(lambda (prefix)
              (add-letter-group-to-manager lgm name prefix
                                           :before before
                                           :after  after))
          prefixes)))
;; line 462 "idxclass.nw"
(defmethod add ((idxcls indexclass) (loccls layered-location-class))
  (let* ((loccls-name (get-name loccls))
         (old-loccls (cdr (lookup-locref-class idxcls loccls-name))))
    (when old-loccls
      (remove-location-class idxcls old-loccls))
    (if (get-locref-classes idxcls) #| if it is empty, we can't rplacd |#
        (rplacd (last (get-locref-classes idxcls))
                (acons loccls-name loccls nil))
        (setf (get-locref-classes idxcls)
              (acons loccls-name loccls nil))))
  idxcls)

(defmethod remove-location-class ((idxcls indexclass)
                                  (loccls layered-location-class))
  (setf (get-locref-classes idxcls)
        (delete-if #'(lambda (elt)
                       (eq (cdr elt) loccls))
                   (get-locref-classes idxcls)))
  idxcls)
;; line 484 "idxclass.nw"
(defmethod add ((idxcls indexclass) (xrefcls crossref-location-class))
  (let ((xrefcls-name (get-name xrefcls)))
    (setf (get-xref-classes idxcls)
          (acons xrefcls-name xrefcls (get-xref-classes idxcls)))
    idxcls))
;; line 495 "idxclass.nw"
(defmethod add-merge-rule ((idxcls indexclass)
                           (catattr-1 category-attribute)
                           (catattr-2 category-attribute))
  (rel-insert (get-merge-rules idxcls) catattr-1 catattr-2)
  idxcls)

(defmethod add-drop-if-merged-rule ((idxcls indexclass)
                                    (catattr-1 category-attribute)
                                    (catattr-2 category-attribute))
  (rel-insert (get-merge-rules idxcls) catattr-1 catattr-2)
  (rel-insert (get-drop-if-merged-rules idxcls) catattr-1 catattr-2)
  idxcls)
;; line 512 "idxclass.nw"
(defmethod add-implicit-substitution-rule (
                                           (idxcls indexclass)
                                           (catattr-1 category-attribute)
                                           (catattr-2 category-attribute))
  (rel-insert (get-implicit-subst-rules idxcls) catattr-1 catattr-2)
  idxcls)


(defmethod add-explicit-substitution-rule (
                                           (idxcls indexclass)
                                           (catattr-1 category-attribute)
                                           (catattr-2 category-attribute))
  (rel-insert (get-explicit-subst-rules idxcls) catattr-1 catattr-2)
  idxcls)
;; line 609 "idxclass.nw"
(defmethod add-rule-set ((idxcls indexclass) (rs rule-set))
  (let ((rule-sets (get-rule-sets idxcls))
        (rs-name (get-name rs)))
    (setf (gethash rs-name rule-sets) rs)))
;; line 635 "idxclass.nw"
(defmethod lookup-basetype ((idxcls indexclass) (basetype-name string))
  (gethash basetype-name (get-basetypes idxcls)))

(defmethod lookup-catattr ((idxcls indexclass) (catattr-name string))
  (lookup-catattr-name (slot-value idxcls 'cat-attrs) catattr-name))

(defmethod lookup-location-class ((idxcls indexclass) (loccls-name string))
  (or (lookup-crossref-class idxcls loccls-name)
      (lookup-locref-class idxcls loccls-name)))

(defmethod lookup-crossref-class ((idxcls indexclass) (xref-name string))
  (assoc xref-name (slot-value idxcls 'xref-classes) :test #'equal))

(defmethod lookup-locref-class ((idxcls indexclass) (loccls-name string))
  (assoc loccls-name (slot-value idxcls 'locref-classes) :test #'equal))

(defmethod lookup-rule-set ((idxcls indexclass) (rule-set-name string))
  (gethash rule-set-name (get-rule-sets idxcls)))
;; line 685 "idxclass.nw"
(defmacro map-location-classes (idxcls apply-func &rest arguments)
  `(LET ()
    (APPLY #'NCONC
           (MAPCAR
            #'(LAMBDA (ELT)
                (LET ((RES
                       (FUNCALL ,apply-func
                                ,idxcls
                                (CDR ELT) #|ELT is ("name".<LOCATION-CLASS>))|#
                                ,@arguments)))
                  (WHEN RES (LIST RES))))
            (GET-LOCREF-CLASSES ,idxcls)))))

;; line 800 "idxclass.nw"
(defmethod apply-substitution-hooks ((idxcls indexclass))
  (let ((impl (get-implicit-subst-rules idxcls))
        (expl (get-explicit-subst-rules idxcls)))
    (funcall (get-implicit-subst-hook idxcls) impl)
    (funcall (get-explicit-subst-hook idxcls) expl)
    (rel-merge impl expl)
    (set-explicit-subst-rules nil idxcls)
    (funcall (get-global-subst-hook idxcls) impl)
    (make-ready impl)
    ))
;; line 838 "idxclass.nw"
(defmethod make-ready ((idxcls indexclass))
  (apply-substitution-hooks idxcls)
  (make-ready (get-merge-rules idxcls))
  (make-ready (get-drop-if-merged-rules idxcls))
  (make-ready (get-letter-groups idxcls))


;;  (set-merge-rule-topsort (topsort
;;                         (remove-reflexivity
;;                          (transform-relation
;;                           (get-drop-if-merged-rules idxcls)
;;                           #'(lambda (attr)
;;                               (get-ordnum attr)))))
;;                        *indexstyle*)

  ;;(pprint (get-drop-if-merged-rules idxcls))
  ;;(pprint (topsort (get-drop-if-merged-rules idxcls)))

  (let ((counter 0))
    (mapc #'(lambda (catattr)
              (set-processing-ordnum (incf counter) catattr))
          (reverse (topsort (get-drop-if-merged-rules idxcls)))))

  idxcls)

;; line 888 "idxclass.nw"
(eval-when (compile load eval)

;; line 109 "idxclass.nw"
(export '(indexclass              make-indexclass
          get-name                get-basetypes
          get-cat-attrs           get-xref-classes
          get-succ-table          get-locref-classes
          get-rule-sets

;; line 241 "idxclass.nw"
          get-merge-rules
          get-drop-if-merged-rules
;          get-merge-rule-topsort   set-merge-rule-topsort
          get-implicit-subst-rules set-implicit-subst-rules
          get-explicit-subst-rules set-explicit-subst-rules
;; line 115 "idxclass.nw"
          ))
;; line 204 "idxclass.nw"
(export '(locref-cache-size*      *locref-cache-rehash-size*
          initialize-locref-cache clear-locref-cache
          lookup-locref-cache     add-locref-cache
          locref-statistics))
;; line 409 "idxclass.nw"
(export '(letter-group-definition match-letter-group))
;; line 530 "idxclass.nw"
(export '(add set
          add-letter-groups
          add-merge-rule
          add-drop-if-merged-rule
          add-implict-substitution-rule
          add-explicit-substitution-rule))
;; line 616 "idxclass.nw"
(export '(rule-set
          make-rule-set
          add-rule-set
          instantiate-rule-set
          inherit-rule-set))
;; line 656 "idxclass.nw"
(export '(lookup-basetype
          lookup-catattr
          lookup-letter-group-definition
          lookup-location-class
          lookup-crossref-class
          lookup-locref-class
          lookup-rule-set))
;; line 700 "idxclass.nw"
(export 'map-location-classes)
;; line 730 "idxclass.nw"
(export '(get-merge-drop-hook set-merge-drop-hook))
;; line 791 "idxclass.nw"
(export '(get-implicit-subst-hook     set-implicit-subst-hook
          get-explicit-subst-hook     set-explicit-subst-hook
          get-global-subst-hook       set-global-subst-hook
          get-substitution-subst-hook set-substitution-subst-hook))
;; line 823 "idxclass.nw"
(export '(apply-substitution-hooks))
;; line 865 "idxclass.nw"
(export '(make-ready))
;; line 890 "idxclass.nw"
  )
;; line 54 "idxstyle.nw"
(defun create-indexclass (idxcls-name)
  (setq *indexstyle* (make-indexclass idxcls-name)))
;; line 259 "letters.nw"
;; $Id$

;; line 37 "letters.nw"
(defclass letter ()
    ((name  :initarg :name  :type string)
     (props :initarg :props :type list)))

(defun make-letter (name properties inherits-from)
  (make-instance 'letter
                 :name  name
                 :props (if inherits-from
                            (append properties (get-props inherits-from))
                            properties)))

(defun find-prop (letter prop)
  (assoc prop (get-props letter)))
;; line 53 "letters.nw"
(defclass letter-dictionary ()
    ((letters :initform (make-hash-table :test #'equal))))

(defun make-letter-dict ()
  (make-instance 'letter-dictionary))

(defun find-letter* (dict-ht letter)
  (gethash letter dict-ht))

(defun find-letter (dict letter)
  (gethash letter (get-letters dict)))

(defun add-letter-to-dict (letter-dict
                           po-dict
                           name props
                           &optional
                           inherits)
  (let ((dict-ht (get-letters letter-dict)))
    (when (gethash name dict-ht)
      (nraw "Letter `~S' redefined!" name))
    (setf (gethash name dict-ht)
          (make-letter name
                       (pre-calculate-props props po-dict)
                       (when inherits
                         (find-letter* dict-ht name))))))
;; line 85 "letters.nw"
(defun pre-calculate-props (props po-dict)
  (mapc #'(lambda (po-spec)
            (let ((po-name (car po-spec))
                  (po-val  (cadr po-spec)))
              (setf (cdr (last po-spec))
                    (list (find-prop-weight
                           (find-partial-order po-dict po-name)
                           po-val)))))
        props)
  props)
;; line 98 "letters.nw"
(defmacro define-letter (&whole whole &rest rest)
  (destructuring-switch-bind (name &rest proplist)
      rest
    (cond
;; line 239 "intface.nw"
((null name)
 (error "missing argument <name> in `~S' !" whole))
((not (or (symbolp name) (stringp name)))
 (error "~S is not a symbol or a string in `~S' !" name whole))
;; line 102 "letters.nw"
          ((not (listp proplist))
             (error "~S is not a property list in ~S." proplist whole))
          (t `(LET ((NAME (STRINGIFY ',name)))
               (ADD-LETTER-TO-DICT
                (GET-LETTER-DICT *INDEXSTYLE*)
                (GET-PARTIAL-ORDER-DICT *INDEXSTYLE*)
                ,name ',proplist))))))
;; line 119 "letters.nw"
(defclass partial-order ()
    ((name   :initarg :name   :type string)
     (order  :initform (make-hash-table :test #'equal))
     (direct :initarg :direct :type symbol)))

(defun make-partial-order (name order &optional (direct :from-start))
  (let* ((po (make-instance 'partial-order :name name :direct direct))
         (po-ht (get-order po))
         (ctr 0))
    (mapc #'(lambda (elt)
              (when (gethash elt po-ht)
                (error "Element ~S doubly defined in partial order ~S."
                       elt name))
              (setf (gethash elt po-ht) (incf ctr)))
          order)
    po))
;; line 140 "letters.nw"
(defclass partial-order-dictionary ()
    ((order :initform (make-hash-table :test #'equal))))

(defun make-partial-order-dict ()
  (make-instance 'partial-order-dictionary))

(defun find-partial-order (dict po-name)
  (gethash po-name (get-order dict)))

(defun find-prop-weight (po po-name)
  (gethash po-name (get-order po)))

(defun add-partial-order-to-dict (dict po-name po-order po-direct)
  (let ((dict-ht (get-order dict)))
    (when (gethash po-name dict-ht)
      (nraw "Partial order ~S redefined!" po-name))
    (setf (gethash po-name dict-ht)
          (make-partial-order po-name po-order po-direct))))
;; line 161 "letters.nw"
(defmacro define-partial-order (&whole whole &rest rest)
  (destructuring-switch-bind (name
                              ordlist
                              &switch
                              from-start
                              from-end)
      rest
    (cond
;; line 239 "intface.nw"
((null name)
 (error "missing argument <name> in `~S' !" whole))
((not (or (symbolp name) (stringp name)))
 (error "~S is not a symbol or a string in `~S' !" name whole))
;; line 169 "letters.nw"
          ((not (listp ordlist))
             (error "~S is not a partial order list in ~S." ordlist whole))
          ((and from-start from-end)
             (error "Only one of :from-start or :from-end is allowed in ~S."
                    whole))
          (t `(LET ((NAME (STRINGIFY ',name)))
               (ADD-PARTIAL-ORDER-TO-DICT
                (GET-PARTIAL-ORDER-DICT *INDEXSTYLE*)
                ,name ',ordlist
                ,(if (or from-start (not from-end))
                     :from-start :from-end)))))))
;; line 194 "letters.nw"
(defun word-cmp (word1 word2 po)
  (let ((po-name (get-name po))
        let1 let2 weight1 weight2)
    (loop
      (cond
        ((and (endp word1) (endp word2)) (return :equal))
        ((endp word1) (return :less))
        ((endp word2) (return :greater))
        (t (setq let1 (car word1))
           (setq word1 (cdr word1))
           (setq let2 (car word2))
           (setq word2 (cdr word2))
           (setq weight1 (lookup-letter-weight let1 po-name))
           (setq weight2 (lookup-letter-weight let2 po-name))
           (when (< weight1 weight2) (return :less))
           (when (> weight1 weight2) (return :greater)))))))

(defun calc-list-of-weights (word po)
  (let ((po-name (get-name po)))
    (mapcar #'(lambda (letter)
                (lookup-letter-weight letter po-name))
            word)))
;; line 227 "letters.nw"
(defun lookup-letter-weight (letter po-name)
  (let ((prop (find-prop letter po-name)))
    (if prop
        (car (last prop))
        (find-prop-weight
         (find-partial-order (get-partial-order-dict *indexstyle*) po-name)
         'others))))
;; line 237 "letters.nw"
(defun make-word (letter-list)
  (let ((dict (get-letter-dict *indexstyle*)))
    (mapcar #'(lambda (str)
                (find-letter dict str))
            letter-list)))

(defun sort-words (word-list po)
  (split-list #'(lambda (word)
                  (calc-list-of-weights word po))
              word-list))



;; line 99 "idxstyle.nw"
(create-indexclass "default")
;; line 107 "idxstyle.nw"
(defmacro string-expand (str)
  (let ((str-expansion
         (map 'list
              #'(lambda (c)
                  (make-string 1 :initial-element c))
              str)))
    `(QUOTE ,str-expansion)))

(define-alphabet* "ALPHA"  (string-expand "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
(define-alphabet* "alpha"  (string-expand "abcdefghijklmnopqrstuvwxyz"))
(define-alphabet* "digits" (string-expand "0123456789"))
;; line 128 "idxstyle.nw"
(defun prefix-match-for-radix-numbers (str radix)
  (let* ((n nil)
         (strlen (length str))
         (len-match (do ((i 0 (1+ i)))
                        ((or (>= i strlen)
                             (not (digit-char-p (char str i) radix)))
                           i)
                      (setq n (+ (* (if n n 0) radix)
                                 (digit-char-p (char str i) radix))))))
    (values (subseq str 0 len-match)
            (subseq str len-match)
            n)))
;; line 155 "idxstyle.nw"
(define-enumeration "arabic-numbers"
                    #'(lambda (str)
                        (prefix-match-for-radix-numbers str 10))
                    "0123456789")
;; line 178 "idxstyle.nw"
(defparameter *lowercase-roman-numbers-lookup-table*
  '((#\i ("ix" . 9) ("iv" . 4) ("iiii" . 4) ("iii". 3) ("ii" . 2) ("i" . 1))
    (#\v ("viiii" . 9)  ("viii" . 8)  ("vii" . 7)  ("vi" . 6)  ("v" . 5))
    (#\x ("xc" . 90) ("xl" . 40) ("x" . 10))
    (#\m ("m" . 1000))
    (#\c ("cm" . 900) ("cd" . 400) ("c" . 100))
    (#\l ("lxxxx" . 90) ("lxxx" . 80) ("lxx" . 70) ("lx" . 60) ("l" . 50))
    (#\d ("dcccc" . 900) ("dccc" . 800) ("dcc" . 700) ("dc" . 600) ("d" . 500))
    ))

(defparameter *uppercase-roman-numbers-lookup-table*
  '((#\I ("IX" . 9) ("IV" . 4) ("IIII" . 4) ("III". 3) ("II" . 2) ("I" . 1))
    (#\V ("VIIII" . 9)  ("VIII" . 8)  ("VII" . 7)  ("VI" . 6)  ("V" . 5))
    (#\X ("XC" . 90) ("XL" . 40) ("X" . 10))
    (#\M ("M" . 1000))
    (#\C ("CM" . 900) ("CD" . 400) ("C" . 100))
    (#\L ("LXXXX" . 90) ("LXXX" . 80) ("LXX" . 70) ("LX" . 60) ("L" . 50))
    (#\D ("DCCCC" . 900) ("DCCC" . 800) ("DCC" . 700) ("DC" . 600) ("D" . 500))
    ))
;; line 206 "idxstyle.nw"
(defun roman-number-prefix-match (roman-number-string *table*)
  (let ((result 0)
        (str roman-number-string)
        (last-val 100000) #| hope that's enough |#
        (str-len (length roman-number-string))
        ch table match-cons curr-val
        )
    (loop (when (= 0 (length str))
            (return (values roman-number-string "" result)))
          (setq ch (aref str 0))
          (setq table (cdr (assoc ch *table*)))
          (setq match-cons
                (find-if #'(lambda (cons)
                             (let* ((prefix (car cons))
                                    (match-len (string/= prefix str)))
                               (or (not match-len)
                                   (= match-len (length prefix)))))
                         table))
          (unless match-cons
            (return (if (= 0 result)
                        (values nil nil nil)
                        (values (subseq roman-number-string
                                        0 (- str-len (length str)))
                                str result))))
          (setq curr-val (cdr match-cons))
          (when (> curr-val last-val)
            (return (values (subseq roman-number-string
                                    0 (- str-len (length str)))
                            str result)))
          (incf result curr-val)
          (setq last-val curr-val)
          (setq str (subseq str (length (car match-cons)))))))
;; line 241 "idxstyle.nw"
(define-enumeration "roman-numbers-uppercase"
                    #'(lambda (str)
                        (roman-number-prefix-match
                         str
                         *uppercase-roman-numbers-lookup-table*))
                    "IVXLCDM")

(add-alias *indexstyle* "roman-numbers-uppercase" "ROMAN")
(add-alias *indexstyle* "roman-numbers-uppercase" "roman-numerals-uppercase")

(define-enumeration "roman-numbers-lowercase"
                    #'(lambda (str)
                        (roman-number-prefix-match
                         str
                         *lowercase-roman-numbers-lookup-table*))
                    "ivxlcdm")

(add-alias *indexstyle* "roman-numbers-lowercase" "roman")
(add-alias *indexstyle* "roman-numbers-lowercase" "roman-numerals-lowercase")


;; line 902 "idxclass.nw"
#+:XP
(defmacro pprint-slot-block (slot-name body)
  `(progn
    (pprint-logical-block (s nil :suffix " }")
                          (pprint-indent :block 2 s)
                          (write-string ,slot-name s)
                          (pprint-newline :mandatory s)
                          ,body)
    (pprint-newline :mandatory s)))

#+:XP
(defmacro pprint-slot-block-line (slot-name body)
  `(progn
    (pprint-logical-block (s nil :suffix " }")
                          (pprint-indent :block 2 s)
                          (write-string ,slot-name s)
                          (pprint-newline :linear s)
                          ,body)
    (pprint-newline :mandatory s)))
;; line 924 "idxclass.nw"
#+:XP
(set-pprint-dispatch 'indexclass
                     #'(lambda (s idxcls)
                         (pprint-logical-block
                          (s nil :suffix "}")
                          (pprint-indent :block 2 s)
                          (write-string "indexclass " s)
                          (write (get-name idxcls) :stream s)
                          (write-string " {" s)
                          (pprint-newline :mandatory s)
                          (pprint-slot-block
                           "basetypes {"
                           (maphash #'(lambda (key bt)
                                        (declare (ignore key))
                                        (write (get-name bt) :stream s)
                                        (write-string " " s)
                                        (pprint-newline :linear s))
                                    (get-basetypes idxcls)))
                          (pprint-slot-block
                           "cat-attrs {"
                           (write (get-cat-attrs idxcls) :stream s))
                          (pprint-slot-block
                           "locclasses {"
                           (mapc #'(lambda (lc)
                                     (write (get-name (cdr lc)) :stream s)
                                     (write-string " [" s)
                                     (write (get-ordnum (cdr lc)) :stream s)
                                     (write-string "] " s)
                                     (pprint-newline :linear s))
                                 (get-locref-classes idxcls)))
                          (pprint-slot-block
                           "xrefclasses {"
                           (mapc #'(lambda (lc)
                                     (write (get-name (cdr lc)) :stream s)
                                     (write-string " [" s)
                                     (write (get-ordnum (cdr lc)) :stream s)
                                     (write-string "] " s)
                                     (pprint-newline :linear s))
                                 (get-xref-classes idxcls)))

                          (write (get-letter-dict idxcls) :stream s)
                          (pprint-newline :mandatory s)
                          (write (get-partial-order-dict idxcls) :stream s)
                          (pprint-newline :mandatory s)

                          (pprint-slot-block
                           "merge-rules {"
                           (write (get-merge-rules idxcls) :stream s))
                          (pprint-slot-block
                           "drop-if-merged-rules {"
                           (write (get-drop-if-merged-rules idxcls) :stream s))
                          ;; (pprint-slot-block-line
                          ;; "merge-rule-topsort { "
                          ;; (write (get-merge-rule-topsort idxcls) :stream s))
                          (pprint-slot-block
                           "implicit-subst-rules {"
                           (write (get-implicit-subst-rules idxcls) :stream s))
                          (pprint-slot-block
                           "explicit-subst-rules {"
                           (write (get-explicit-subst-rules idxcls) :stream s))

                          (pprint-slot-block-line
                           "implicit-subst-hook {"
                           (write (get-implicit-subst-hook idxcls) :stream s))
                          (pprint-slot-block-line
                           "explicit-subst-hook {"
                           (write (get-explicit-subst-hook idxcls) :stream s))
                          (pprint-slot-block-line
                           "global-subst-hook {"
                           (write (get-global-subst-hook idxcls) :stream s))
                          (pprint-slot-block-line
                           "substitution-subst-hook {"
                           (write (get-substitution-subst-hook idxcls) :stream s))
                          (pprint-slot-block-line
                           "merge-drop-hook {"
                           (write (get-merge-drop-hook idxcls) :stream s))

                                        ;                          (pprint-slot-block
                                        ;                           "keyword-markup {"
                                        ;                           (write (get-keyword-markup idxcls) :stream s))
                          )))
;; line 580 "idxrule.nw"
#+:XP
(defun pprint-relation (s rel)
  (pprint-logical-block
   (s nil :suffix "}")
   (pprint-indent :block 2 s)
   (write-string "Relation { " s)
   (pprint-logical-block (s nil)
                         (pprint-indent :block 2)
                         (mapc #'(lambda (x)
                                   (when x
                                     (write (car x) :stream s)
                                     (write-string " ->" s)
                                     (mapc #'(lambda (y)
                                               (write-string " " s)
                                               (write y :stream s))
                                           (cdr x))
                                     (pprint-newline :mandatory s)))
                               (get-rel-sets rel)))))

#+:XP
(set-pprint-dispatch 'relation-rule #'pprint-relation)
#+:XP
(set-pprint-dispatch 'relation      #'pprint-relation)
;; line 606 "idxrule.nw"
#+:XP
(set-pprint-dispatch
 'catattr-groups
 #'(lambda (s catgrp)
     (pprint-logical-block
      (s nil :suffix "}")
      (pprint-indent :block 2 s)
      (write-string "Category-attribute-group { " s)
      (pprint-newline :mandatory s)
      (write (get-attribute-list catgrp) :stream s)
      (pprint-newline :mandatory s)
      (write (get-attribute-table catgrp) :stream s))))
;; line 277 "letters.nw"
#+:XP
(set-pprint-dispatch 'letter
                     #'(lambda (s lt)
                         (pprint-logical-block
                          (s nil :suffix ">")
                          (pprint-indent :block 2 s)
                          (write-string "<" s)
                          (write (get-name lt) :stream s)
                          (write-string " " s)
                          (pprint-newline :linear s)
                          (write (get-props lt) :stream s))))

#+:XP
(set-pprint-dispatch 'letter-dictionary
                     #'(lambda (s dict)
                         (pprint-logical-block
                          (s nil :suffix "}")
                          (pprint-indent :block 2 s)
                          (write-string "letters {" s)
                          (maphash #'(lambda (key lt)
                                       (declare (ignore key))
                                       (write lt :stream s)
                                       (write-string " " s)
                                       (pprint-newline :linear s))
                                   (get-letters dict)))))

#+:XP
(set-pprint-dispatch 'partial-order
                     #'(lambda (s po)
                         (pprint-logical-block
                          (s nil :suffix ">")
                          (pprint-indent :block 2 s)
                          (write-string "<" s)
                          (write (get-name po) :stream s)
                          (pprint-newline :linear s)
                          (maphash #'(lambda (key po)
                                       (write-string " [" s)
                                       (write key :stream s)
                                       (write-string " " s)
                                       (write po :stream s)
                                       (write-string "]" s)
                                       (pprint-newline :linear s))
                                   (get-order po)))))


#+:XP
(set-pprint-dispatch 'partial-order-dictionary
                     #'(lambda (s dict)
                         (pprint-logical-block
                          (s nil :suffix "}")
                          (pprint-indent :block 2 s)
                          (write-string "partial-orders {" s)
                          (maphash #'(lambda (key po)
                                       (declare (ignore key))
                                       (write po :stream s)
                                       (write-string " " s)
                                       (pprint-newline :linear s))
                                   (get-order dict)))))

;; line 321 "idxstyle.nw"
(defvar *RCS-Identifier* '(
;; line 894 "idxclass.nw"
("idxclass" . "$Id: idxclass.nw,v 1.20 1997/03/26 16:18:16 kehr Exp $")
;; line 572 "idxrule.nw"
("idxrule" . "$Id: idxrule.nw,v 1.10 1997/03/26 16:18:19 kehr Exp $")
;; line 335 "idxstyle.nw"
("idxstyle" . "$Id: idxstyle.nw,v 1.19 1997/03/26 16:18:23 kehr Exp $")
;; line 1174 "intface.nw"
("intface" . "$Id: intface.nw,v 1.30 1997/10/20 11:25:09 kehr Exp $")
;; line 269 "letters.nw"
("letters" . "$Id$")
;; line 321 "idxstyle.nw"
                                               ))

(eval-when (compile load eval)

;; line 59 "idxstyle.nw"
(export 'create-indexclass)
;; line 89 "idxstyle.nw"
(export '*load-paths*)
;; line 325 "idxstyle.nw"
  )