summaryrefslogtreecommitdiff
path: root/Build/source/utils/xindy/xindy-2.4/src
diff options
context:
space:
mode:
authorPeter Breitenlohner <peb@mppmu.mpg.de>2011-03-13 13:16:44 +0000
committerPeter Breitenlohner <peb@mppmu.mpg.de>2011-03-13 13:16:44 +0000
commita002c295ae6054a4cfb9825ddb6e0d4f27ecde73 (patch)
tree1addafb42ef483a7ceb41abed3e9c877f808ee00 /Build/source/utils/xindy/xindy-2.4/src
parent908bf11dbd760fe92209f9c1fe90502a44fa90fc (diff)
reorganize xindy-2.4 build system (part 1)
git-svn-id: svn://tug.org/texlive/trunk@21706 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Build/source/utils/xindy/xindy-2.4/src')
-rw-r--r--Build/source/utils/xindy/xindy-2.4/src/Makefile.am71
-rw-r--r--Build/source/utils/xindy/xindy-2.4/src/Makefile.in430
-rw-r--r--Build/source/utils/xindy/xindy-2.4/src/base.lsp237
-rw-r--r--Build/source/utils/xindy/xindy-2.4/src/defaults.xdy.in5
-rw-r--r--Build/source/utils/xindy/xindy-2.4/src/dump-xindy.lsp33
-rw-r--r--Build/source/utils/xindy/xindy-2.4/src/idxstyle.lsp2127
-rw-r--r--Build/source/utils/xindy/xindy-2.4/src/index.lsp1333
-rw-r--r--Build/source/utils/xindy/xindy-2.4/src/locref.lsp556
-rw-r--r--Build/source/utils/xindy/xindy-2.4/src/markup.lsp1289
-rw-r--r--Build/source/utils/xindy/xindy-2.4/src/ordrules.lsp419
-rw-r--r--Build/source/utils/xindy/xindy-2.4/src/version.lsp13
11 files changed, 6513 insertions, 0 deletions
diff --git a/Build/source/utils/xindy/xindy-2.4/src/Makefile.am b/Build/source/utils/xindy/xindy-2.4/src/Makefile.am
new file mode 100644
index 00000000000..d7aac1f3854
--- /dev/null
+++ b/Build/source/utils/xindy/xindy-2.4/src/Makefile.am
@@ -0,0 +1,71 @@
+## Use `autoreconf' in top-level directory to recreate all
+## autoconf/automake files.
+## Or, call `automake Makefile' to create only Makefile.in.
+
+## Copyright (C) 2004-2005 by Gour.
+## Copyright (C) 2008,2009 by Joachim Schrod.
+##
+## This program is free software; you can redistribute it and/or
+## modify it under the terms of the GNU General Public License as
+## published by the Free Software Foundation; either version 2 of the
+## License, or (at your option) any later version.
+##
+## This program is distributed in the hope that it will be useful, but
+## WITHOUT ANY WARRANTY; without even the implied warranty of
+## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+## General Public License for more details.
+##
+## You should have received a copy of the GNU General Public License
+## along with this program in the file COPYING; if not, write to the
+## Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+## Boston, MA 02110-1301 USA.
+
+# Where the modules are found at runtime.
+MODULEDIR = $(pkglibdir)/modules
+
+
+# Automake has no CLISP support; moreover xindy.mem is not a binary
+# to be stripped upon 'make install-strip'. We define it as DATA.
+mem_DATA = xindy.mem
+
+# Tell the dist target about our sources, define the object files for
+# our own rule and the .lib files for the clean definition. Don't use
+# gmake-isms.
+FASSRC = base.lsp ordrules.lsp locref.lsp idxstyle.lsp \
+ index.lsp version.lsp markup.lsp
+FAS = base.fas ordrules.fas locref.fas idxstyle.fas \
+ index.fas version.fas markup.fas
+FASLIBS = base.lib ordrules.lib locref.lib idxstyle.lib \
+ index.lib version.lib markup.lib
+
+DEFAULTS = defaults.xdy
+DUMP_XINDY = dump-xindy.lsp
+MEMFILE = xindy.mem
+CLISP = @CLISP@ -q -E iso-8859-1
+
+xindy.mem: $(DEFAULTS) $(FAS) $(DUMP_XINDY)
+ rm -f $(MEMFILE)
+ $(CLISP) $(srcdir)/$(DUMP_XINDY)
+ if test "$(host_os)" != "mingw32"; then \
+ gzip -9n $@; \
+ mv $@.gz $@; \
+ fi
+
+$(DEFAULTS): $(DEFAULTS).in Makefile
+ sed 's|@MODULEDIR[@]|$(MODULEDIR)|g' <$(srcdir)/$(DEFAULTS).in >$(DEFAULTS)
+
+EXTRA_DIST = $(DEFAULTS).in $(FASSRC) dump-xindy.lsp
+
+SUFFIXES = .fas .lsp
+.lsp.fas:
+ $(CLISP) -c $< -o $@
+
+
+CLEANFILES = $(FAS) $(FASLIBS) $(DEFAULTS) xindy.mem
+
+# Dependencies required for parallel make.
+markup.fas: index.fas version.fas
+index.fas: idxstyle.fas ordrules.fas
+idxstyle.fas: locref.fas
+locref.fas: base.fas
+
diff --git a/Build/source/utils/xindy/xindy-2.4/src/Makefile.in b/Build/source/utils/xindy/xindy-2.4/src/Makefile.in
new file mode 100644
index 00000000000..8cd29769801
--- /dev/null
+++ b/Build/source/utils/xindy/xindy-2.4/src/Makefile.in
@@ -0,0 +1,430 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+subdir = xindy/src
+DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.in
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/../../m4/kpse-warnings.m4 \
+ $(top_srcdir)/xindy/VERSION $(top_srcdir)/ac/xindy.ac \
+ $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES =
+CONFIG_CLEAN_VPATH_FILES =
+SOURCES =
+DIST_SOURCES =
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__installdirs = "$(DESTDIR)$(memdir)"
+DATA = $(mem_DATA)
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+pkglibdir = @pkglibdir@
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CLISP = @CLISP@ -q -E iso-8859-1
+CONVERT_FROM_UTF8 = @CONVERT_FROM_UTF8@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EXEEXT = @EXEEXT@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LATEX = @LATEX@
+LDFLAGS = @LDFLAGS@
+LEX = @LEX@
+LEXLIB = @LEXLIB@
+LEX_OUTPUT_ROOT = @LEX_OUTPUT_ROOT@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LISP_RUN = @LISP_RUN@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAINT = @MAINT@
+MAKEINFO = @MAKEINFO@
+MKDIR_P = @MKDIR_P@
+OBJEXT = @OBJEXT@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+PDFLATEX = @PDFLATEX@
+PERL = @PERL@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+WARNING_CFLAGS = @WARNING_CFLAGS@
+XINDY_RUN = @XINDY_RUN@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_CC = @ac_ct_CC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+mandir = @mandir@
+memdir = @memdir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+
+# Where the modules are found at runtime.
+MODULEDIR = $(pkglibdir)/modules
+
+# Automake has no CLISP support; moreover xindy.mem is not a binary
+# to be stripped upon 'make install-strip'. We define it as DATA.
+mem_DATA = xindy.mem
+
+# Tell the dist target about our sources, define the object files for
+# our own rule and the .lib files for the clean definition. Don't use
+# gmake-isms.
+FASSRC = base.lsp ordrules.lsp locref.lsp idxstyle.lsp \
+ index.lsp version.lsp markup.lsp
+
+FAS = base.fas ordrules.fas locref.fas idxstyle.fas \
+ index.fas version.fas markup.fas
+
+FASLIBS = base.lib ordrules.lib locref.lib idxstyle.lib \
+ index.lib version.lib markup.lib
+
+DEFAULTS = defaults.xdy
+DUMP_XINDY = dump-xindy.lsp
+MEMFILE = xindy.mem
+EXTRA_DIST = $(DEFAULTS).in $(FASSRC) dump-xindy.lsp
+SUFFIXES = .fas .lsp
+CLEANFILES = $(FAS) $(FASLIBS) $(DEFAULTS) xindy.mem
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .fas .lsp
+$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign xindy/src/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --foreign xindy/src/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+install-memDATA: $(mem_DATA)
+ @$(NORMAL_INSTALL)
+ test -z "$(memdir)" || $(MKDIR_P) "$(DESTDIR)$(memdir)"
+ @list='$(mem_DATA)'; test -n "$(memdir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(memdir)'"; \
+ $(INSTALL_DATA) $$files "$(DESTDIR)$(memdir)" || exit $$?; \
+ done
+
+uninstall-memDATA:
+ @$(NORMAL_UNINSTALL)
+ @list='$(mem_DATA)'; test -n "$(memdir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(memdir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(memdir)" && rm -f $$files
+tags: TAGS
+TAGS:
+
+ctags: CTAGS
+CTAGS:
+
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-am
+all-am: Makefile $(DATA)
+installdirs:
+ for dir in "$(DESTDIR)$(memdir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+ -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-generic mostlyclean-am
+
+distclean: distclean-am
+ -rm -f Makefile
+distclean-am: clean-am distclean-generic
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am: install-memDATA
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am:
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-generic
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-memDATA
+
+.MAKE: install-am install-strip
+
+.PHONY: all all-am check check-am clean clean-generic distclean \
+ distclean-generic distdir dvi dvi-am html html-am info info-am \
+ install install-am install-data install-data-am install-dvi \
+ install-dvi-am install-exec install-exec-am install-html \
+ install-html-am install-info install-info-am install-man \
+ install-memDATA install-pdf install-pdf-am install-ps \
+ install-ps-am install-strip installcheck installcheck-am \
+ installdirs maintainer-clean maintainer-clean-generic \
+ mostlyclean mostlyclean-generic pdf pdf-am ps ps-am uninstall \
+ uninstall-am uninstall-memDATA
+
+
+xindy.mem: $(DEFAULTS) $(FAS) $(DUMP_XINDY)
+ rm -f $(MEMFILE)
+ $(CLISP) $(srcdir)/$(DUMP_XINDY)
+ if test "$(host_os)" != "mingw32"; then \
+ gzip -9n $@; \
+ mv $@.gz $@; \
+ fi
+
+$(DEFAULTS): $(DEFAULTS).in Makefile
+ sed 's|@MODULEDIR[@]|$(MODULEDIR)|g' <$(srcdir)/$(DEFAULTS).in >$(DEFAULTS)
+.lsp.fas:
+ $(CLISP) -c $< -o $@
+
+# Dependencies required for parallel make.
+markup.fas: index.fas version.fas
+index.fas: idxstyle.fas ordrules.fas
+idxstyle.fas: locref.fas
+locref.fas: base.fas
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/Build/source/utils/xindy/xindy-2.4/src/base.lsp b/Build/source/utils/xindy/xindy-2.4/src/base.lsp
new file mode 100644
index 00000000000..4158d212f7b
--- /dev/null
+++ b/Build/source/utils/xindy/xindy-2.4/src/base.lsp
@@ -0,0 +1,237 @@
+;; line 30 "base.nw"
+(lisp:defpackage "BASE")
+(lisp:in-package "BASE")
+(lisp:provide "base")
+
+#+:CMU17 (defpackage "CLOS")
+
+(eval-when (compile load eval)
+ (lisp:use-package "CLOS")
+ (lisp:use-package "COMMON-LISP")
+ #+CLISP (lisp:use-package "EXT")
+ )
+
+(eval-when (eval load compile)
+ #+CLISP (when (find-package "XP")
+ (pushnew :XP *features*))
+ #+(or ALLEGRO :CMU17) (pushnew :XP *features*)
+ )
+
+(setq *print-pretty* t)
+(setq *print-escape* t)
+
+(defparameter *mappings-trace* nil)
+(defparameter *locref-trace* nil)
+(eval-when (compile load eval)
+ (export '(*mappings-trace* *locref-trace*)))
+
+;; line 104 "base.nw"
+#-CLISP
+(defmacro simple-condition-format-string (&rest args)
+ `(simple-condition-format-control ,@args))
+#-CLISP
+(eval-when (compile load eval)
+ (export '(simple-condition-format-string)))
+;; line 133 "base.nw"
+(defmacro info (&rest msg)
+ `(APPLY #'FORMAT *STANDARD-OUTPUT* (LIST ,@msg)))
+;; line 138 "base.nw"
+(defparameter *nraw-error-message* "~&WARNING: ")
+
+(defmacro nraw (&rest msg)
+ `(PROGN
+ (FORMAT *ERROR-OUTPUT* BASE::*NRAW-ERROR-MESSAGE*)
+ (APPLY #'FORMAT *ERROR-OUTPUT* (LIST ,@msg))))
+;; line 147 "base.nw"
+(defparameter *oops-error-message* "~&ERROR: ")
+
+(defmacro oops (&rest msg)
+ `(LET ((MSG (LIST ,@msg)))
+ (FORMAT *ERROR-OUTPUT* BASE::*OOPS-ERROR-MESSAGE*)
+ (APPLY #'FORMAT *ERROR-OUTPUT* MSG)
+ (WHEN *LOGGING-ON*
+ (FORMAT *LOGGING-STREAM* BASE::*OOPS-ERROR-MESSAGE*)
+ (APPLY #'FORMAT *LOGGING-STREAM* MSG))))
+;; line 162 "base.nw"
+(defmacro oops* (fmt args)
+ `(LET ((FMT ,fmt)
+ (ARGS ,args))
+ (FORMAT *ERROR-OUTPUT* BASE::*OOPS-ERROR-MESSAGE*)
+ (APPLY #'FORMAT *ERROR-OUTPUT* FMT ARGS)
+ (WHEN *LOGGING-ON*
+ (FORMAT *LOGGING-STREAM* BASE::*OOPS-ERROR-MESSAGE*)
+ (APPLY #'FORMAT *LOGGING-STREAM* FMT ARGS))))
+;; line 183 "base.nw"
+(defparameter *logging-stream* nil)
+(defparameter *logging-on* nil)
+
+(defmacro gol (flag &rest msg)
+ `(WHEN (AND ,flag *LOGGING-ON*)
+ (APPLY #'FORMAT *LOGGING-STREAM* (list ,@msg))))
+;; line 74 "base.nw"
+(defmacro ifnot (expr then-body else-body)
+ `(IF (NOT ,expr) ,then-body ,else-body))
+;; line 82 "base.nw"
+(defun error-exit ()
+ #+CLISP (exit 1)
+ #+ALLEGRO (excl:exit 1)
+ #+CMU17 (unix:unix-exit 1)
+ )
+
+(defun exit-normally ()
+ #+CLISP (exit 0)
+ #+ALLEGRO (excl:exit 0)
+ #+CMU17 (unix:unix-exit 0)
+ )
+;; line 201 "base.nw"
+(defmacro assert! (cond &optional msg)
+ `(UNLESS ,cond
+ (FORMAT *ERROR-OUTPUT* "Internal error! Assertion ~A failed!" ',cond)
+ ,(if msg
+ `(ERROR "~S" ,msg)
+ `(ERROR "Entering debugger!"))))
+
+(pushnew :ASSERT! *features*)
+;; line 218 "base.nw"
+(defmacro define-slot-accessors (accessors)
+ `(eval-when (compile load eval)
+ ,@(apply #'nconc
+ (mapcar
+ #'(lambda (acc)
+ (let ((getnam (intern (concatenate 'string "GET-"
+ (symbol-name acc))))
+ (setnam (intern (concatenate 'string "SET-"
+ (symbol-name acc))))
+ )
+ `((defmacro ,getnam (obj)
+ (list 'slot-value obj '',acc))
+ (defmacro ,setnam (val obj)
+ (list 'setf (list 'slot-value obj '',acc) val))
+ (export '(,getnam ,setnam ,acc)))))
+ accessors))))
+
+(define-slot-accessors (
+ attribute
+ base-alphabet
+ basetype
+ catattr
+ catattr-grp-ordnum
+ entries
+ entry-list
+ entry-table
+ first
+ group-definition
+ hierdepth
+ idxclass
+ inner
+ join-length
+ last
+ last-in-group
+ layers
+ length
+ letters
+ locclass
+ locref-cache
+ locref-string
+ locrefs
+ members
+ merge-key
+ sort-key
+ print-key
+ main-key
+ name
+ order
+ ordnum
+ ordnums
+ origin
+ processing-ordnum
+ props
+ rangeattr
+ separator
+ sort-ordnum
+ state
+ subentries
+ subrefs
+ symbols
+ target
+ type
+ ))
+;; line 297 "base.nw"
+(defun split-list (split-function list &key sortfunc headfunc)
+ #+:ASSERT! (assert (not (and sortfunc headfunc))
+ ()
+ "split-list")
+ (let ((list-len (length list)))
+ (if (= 1 list-len)
+ (list list)
+ (let ((split-table (make-hash-table :test #'equal
+ :size (round (* 1.2 list-len))))
+ (key-list '()))
+ (mapc #'(lambda (elt)
+ (let ((key (funcall split-function elt)))
+ (setf (gethash key split-table)
+ (cons elt (gethash key split-table)))))
+ list)
+ (maphash #'(lambda (key element)
+ (declare (ignore element))
+ (push key key-list))
+ split-table)
+ (maplist #'(lambda (rest-list)
+ (let ((entries (gethash (car rest-list) split-table)))
+ (if headfunc
+ (let ((head (find-if headfunc entries)))
+ (rplaca rest-list
+ (if head
+ (cons head (delete head entries))
+ entries)))
+ (rplaca rest-list entries))))
+ (if sortfunc (sort key-list sortfunc) key-list))
+ key-list))))
+
+#|
+This version seems to be a little bit slower than the above one,
+despite the fact that we use a temporary array with a fill-pointer.
+
+(defun split-list (split-function sort-function list)
+ (let ((list-len (length list)))
+ (if (= 1 list-len)
+ (list list)
+ (let ((split-table (make-hash-table :test #'equal
+ :size (round (* 1.5 list-len)))))
+ (mapc #'(lambda (elt)
+ (let ((key (funcall split-function elt)))
+ (setf (gethash key split-table)
+ (cons elt (gethash key split-table)))))
+ list)
+ (let ((sort-array (make-array (hash-table-count split-table)
+ :fill-pointer 0)))
+ (maphash #'(lambda (key element)
+ (declare (ignore element))
+ (vector-push key sort-array))
+ split-table)
+ (map 'list
+ #'(lambda (key)
+ (gethash key split-table))
+ (sort sort-array sort-function)))))))
+|#
+
+;; line 60 "base.nw"
+(defvar *RCS-Identifier* '(
+;; line 68 "base.nw"
+("base" . "$Id: base.nw,v 1.20 1997/03/26 16:17:58 kehr Exp $")
+;; line 60 "base.nw"
+ ))
+
+(eval-when (compile load eval)
+
+;; line 96 "base.nw"
+(export '(ifnot error-exit exit-normally))
+;; line 192 "base.nw"
+(export '(oops oops* nraw info gol
+ *logging-stream* *logging-on*))
+;; line 212 "base.nw"
+(export 'assert!)
+;; line 357 "base.nw"
+(export '(split-list))
+;; line 64 "base.nw"
+ )
diff --git a/Build/source/utils/xindy/xindy-2.4/src/defaults.xdy.in b/Build/source/utils/xindy/xindy-2.4/src/defaults.xdy.in
new file mode 100644
index 00000000000..bd149fdbae0
--- /dev/null
+++ b/Build/source/utils/xindy/xindy-2.4/src/defaults.xdy.in
@@ -0,0 +1,5 @@
+;; defaults.xdy.in 29 Mar 09 -*- Lisp -*-
+;;------------------------------------------------------------
+
+(setq *load-paths* (list (pathname ".")
+ (pathname "@MODULEDIR@")))
diff --git a/Build/source/utils/xindy/xindy-2.4/src/dump-xindy.lsp b/Build/source/utils/xindy/xindy-2.4/src/dump-xindy.lsp
new file mode 100644
index 00000000000..73dc63677bd
--- /dev/null
+++ b/Build/source/utils/xindy/xindy-2.4/src/dump-xindy.lsp
@@ -0,0 +1,33 @@
+;; $Id: dump-xindy.xdy,v 1.2 1996/08/02 17:41:07 kehr Exp $
+;; ----------------------------------------------------------------------
+;;
+;; This file is necessary to dump xindy.
+;;
+
+#+CLISP (setq custom:*suppress-check-redefinition* t)
+
+(load 'base)
+(load 'locref)
+(load 'ordrules)
+(load 'idxstyle)
+(load 'index)
+(load 'version)
+(load 'markup)
+
+(load "defaults.xdy")
+
+(setq *load-verbose* nil)
+
+(shadow 'require)
+(lisp:shadowing-import idxstyle:*idxstyle-user-interface-definitions*)
+(lisp:import markup:*markup-user-interface-definitions*)
+(lisp:import index:*raw-index-interface-definitions*)
+
+;; Install the break-driver if its feature exists.
+#+:BREAK-DRIVER
+(setq *break-driver* #'xindy:*break-driver*)
+
+(gc)
+
+(saveinitmem "xindy.mem" :quiet t)
+(exit)
diff --git a/Build/source/utils/xindy/xindy-2.4/src/idxstyle.lsp b/Build/source/utils/xindy/xindy-2.4/src/idxstyle.lsp
new file mode 100644
index 00000000000..2a561aee7f9
--- /dev/null
+++ b/Build/source/utils/xindy/xindy-2.4/src/idxstyle.lsp
@@ -0,0 +1,2127 @@
+;; 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")
+#+CLISP (lisp:require "ordrules")
+
+(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
+ (ORDRULES:ADD-KEYWORD-MERGE-RULE ,pattern ,replacement
+ ,(if again 1 0)
+ ,(cond (string 1)
+ (basic-regexp 2)
+ (extended-regexp 3)
+ (t 0)))
+ (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
+ (ORDRULES:ADD-KEYWORD-SORT-RULE ,run ,pattern ,replacement
+ ,(if again 1 0)
+ ,(cond (string 1)
+ (basic-regexp 2)
+ (extended-regexp 3)
+ (t 0)))
+ (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 #\;
+ #+WIN32 #\;
+ 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"
+ )
diff --git a/Build/source/utils/xindy/xindy-2.4/src/index.lsp b/Build/source/utils/xindy/xindy-2.4/src/index.lsp
new file mode 100644
index 00000000000..7d171f96fab
--- /dev/null
+++ b/Build/source/utils/xindy/xindy-2.4/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"
+ ))
diff --git a/Build/source/utils/xindy/xindy-2.4/src/locref.lsp b/Build/source/utils/xindy/xindy-2.4/src/locref.lsp
new file mode 100644
index 00000000000..428b629e910
--- /dev/null
+++ b/Build/source/utils/xindy/xindy-2.4/src/locref.lsp
@@ -0,0 +1,556 @@
+;; line 360 "locref.nw"
+;; $Id: locref.nw,v 1.29 1997/03/26 16:18:53 kehr Exp $
+
+(lisp:defpackage "LOCREF")
+(lisp:in-package "LOCREF")
+(lisp:provide "locref")
+
+#+CLISP (lisp:require "base")
+
+(eval-when (compile load eval)
+ #-CLISP (lisp:require "base")
+ (lisp:use-package "BASE")
+ #+(and :XP CLISP) (lisp:use-package "XP")
+ (lisp:use-package "CLOS"))
+
+;; line 251 "basetype.nw"
+;; $Id: basetype.nw,v 1.17 1997/03/26 16:18:47 kehr Exp $
+
+;; line 110 "basetype.nw"
+(defgeneric prefix-match (str object))
+;; line 114 "basetype.nw"
+(defclass basetype ()
+ ((name :initarg :name)
+ (base-alphabet :initarg :base-alphabet)))
+;; line 142 "basetype.nw"
+(defclass alphabet (basetype)
+ ((symbols :initarg :symbols)))
+
+(defun make-alphabet (name symbols)
+ (make-instance 'alphabet :name name :symbols symbols
+ :base-alphabet (calculate-base-alphabet symbols)))
+
+(defmethod make-copy ((alph alphabet) new-name)
+ (make-instance 'alphabet
+ :name new-name
+ :symbols (get-symbols alph)
+ :base-alphabet (get-base-alphabet alph)))
+;; line 163 "basetype.nw"
+(defun calculate-base-alphabet (list-of-strings)
+ (sort (remove-duplicates
+ (apply #'nconc
+ (mapcar #'(lambda (str)
+ (coerce str 'list))
+ list-of-strings)))
+ #'char<))
+;; line 183 "basetype.nw"
+(defmethod prefix-match ((str string) (alph alphabet))
+ (multiple-value-bind (matched-string rest-string order-num)
+ (prefix-match-stringlist str (get-symbols alph))
+ (values matched-string rest-string order-num)))
+
+(defun prefix-match-stringlist (pattern list-of-str)
+ (let* ((matched-string "")
+ (rest-string pattern)
+ (ordnum-of-max-match nil)
+ (len-max-match 0)
+ (strlen (length pattern)))
+ (do ((ordnum 0 (1+ ordnum))
+ (string-list list-of-str (cdr string-list)))
+ ((endp string-list))
+ (let ((len-curr-match (string/= pattern (car string-list))))
+ (when (null len-curr-match) (setq len-curr-match strlen))
+ (when (> len-curr-match len-max-match)
+ (setq ordnum-of-max-match ordnum)
+ (setq len-max-match len-curr-match)
+ (setq rest-string (subseq pattern len-curr-match))
+ (setq matched-string
+ (subseq (car string-list) 0 len-curr-match)))))
+ (values matched-string rest-string ordnum-of-max-match)))
+;; line 227 "basetype.nw"
+(defclass enumeration (basetype)
+ ())
+
+(defun make-enumeration (enum-class name base-alphabet)
+ (make-instance enum-class
+ :name name
+ :base-alphabet base-alphabet))
+
+(defmethod make-copy ((enum enumeration) new-name)
+ (make-instance (class-name (class-of enum))
+ :name new-name
+ :base-alphabet (get-base-alphabet enum)))
+
+;; line 257 "basetype.nw"
+(eval-when (compile load eval)
+
+;; line 120 "basetype.nw"
+(export '(basetype prefix-match get-name get-base-alphabet))
+;; line 157 "basetype.nw"
+(export '(alphabet make-alphabet get-symbols make-copy))
+;; line 242 "basetype.nw"
+(export '(enumeration make-enumeration))
+;; line 259 "basetype.nw"
+ )
+;; line 493 "locclass.nw"
+;; $Id: locclass.nw,v 1.21 1997/03/26 16:18:49 kehr Exp $
+
+;; line 67 "locclass.nw"
+(defclass location-class ()
+ ((name :type string :initarg :name)
+ (ordnum :type number :initform (gen-next-loccls-ordnum))))
+;; line 87 "locclass.nw"
+(defparameter *curr-loccls-ordnum* 0)
+
+(defun gen-next-loccls-ordnum ()
+ (incf *curr-loccls-ordnum*))
+;; line 106 "locclass.nw"
+(defclass layered-location-class (location-class)
+ ((layers :initarg :layers)
+ (hierdepth :initarg :hierdepth)))
+;; line 125 "locclass.nw"
+(defclass standard-location-class (layered-location-class)
+ ((join-length :initarg :join-length)))
+
+(defun make-standard-location-class (name layers join-length hierdepth)
+ (make-instance 'standard-location-class
+ :name name :layers layers
+ :join-length join-length :hierdepth hierdepth))
+;; line 135 "locclass.nw"
+(defmacro joining-allowed-p (loccls)
+ `(SLOT-VALUE ,loccls 'JOIN-LENGTH))
+;; line 144 "locclass.nw"
+(defun checked-make-standard-location-class (name layers join-layers
+ &optional (hierdepth 0))
+ (make-standard-location-class name layers join-layers hierdepth))
+;; line 163 "locclass.nw"
+(defclass var-location-class (layered-location-class)
+ ())
+
+(defun make-var-location-class (name layers hierdepth)
+ (make-instance 'var-location-class
+ :name name :layers layers :hierdepth hierdepth))
+;; line 172 "locclass.nw"
+(defun checked-make-var-location-class (name layers &optional (hierdepth 0))
+ (make-var-location-class name layers hierdepth))
+;; line 189 "locclass.nw"
+(defclass loccls-layer ()
+ ((basetype :initarg :basetype)))
+
+(defun make-loccls-layer (basetype)
+ (make-instance 'loccls-layer :basetype basetype))
+;; line 206 "locclass.nw"
+(defmethod prefix-match ((locstring string)
+ (layer loccls-layer))
+ (prefix-match locstring (get-basetype layer)))
+;; line 220 "locclass.nw"
+(defclass loccls-separator ()
+ ((separator :initarg :separator)))
+
+(defun make-loccls-separator (separator)
+ (make-instance 'loccls-separator :separator separator))
+;; line 246 "locclass.nw"
+(defmethod prefix-match ((locstring string)
+ (separator loccls-separator))
+ (let* ((sepstr (get-separator separator))
+ (seplen (length sepstr))
+ (match-len (string/= sepstr locstring)))
+ (if (or (null match-len) (eql seplen match-len))
+ (values locstring (subseq locstring seplen) t)
+ (values nil nil nil))))
+;; line 273 "locclass.nw"
+(defclass crossref-location-class (location-class)
+ ((target :initarg :target)))
+;; line 299 "locclass.nw"
+(defclass verified-crossref-location-class (crossref-location-class)
+ ())
+
+(defun make-verified-crossref-location-class (name)
+ (make-instance 'verified-crossref-location-class :name name))
+;; line 319 "locclass.nw"
+(defclass unverified-crossref-location-class (crossref-location-class)
+ ())
+
+(defun make-unverified-crossref-location-class (name)
+ (make-instance 'unverified-crossref-location-class :name name))
+
+;; line 374 "locclass.nw"
+(defgeneric perform-match (locstring locclass))
+;; line 402 "locclass.nw"
+(defmethod perform-match ((locstring string)
+ (loccls standard-location-class))
+ (let ((layer-list '())
+ (ordnum-list '())
+ (give-up nil)
+ (matched-string nil)
+ (rest-string nil)
+ (ordnum nil))
+ (do ((layers (get-layers loccls) (cdr layers)))
+ ((or give-up
+ (let ((empty-string (= 0 (length locstring)))
+ (empty-list (endp layers)))
+ (cond ((and empty-string empty-list) t)
+ ((or empty-string empty-list) (setq give-up t))
+ (t nil)))))
+ (let ((curr-layer (car layers)))
+ (multiple-value-setq (matched-string rest-string ordnum)
+ (prefix-match locstring curr-layer))
+ (cond ((eq ordnum nil) (setq give-up t))
+ ((numberp ordnum)
+ (setq locstring rest-string)
+ (setq layer-list
+ (cons matched-string layer-list))
+ (setq ordnum-list (cons ordnum ordnum-list)))
+ (t (setq locstring rest-string)))
+ ))
+ (if (not give-up)
+ (values (nreverse layer-list) (nreverse ordnum-list))
+ (values nil nil))))
+;; line 446 "locclass.nw"
+(defmethod perform-match ((locstring string)
+ (loccls var-location-class))
+ (let ((layer-list '())
+ (ordnum-list '())
+ (give-up nil)
+ (matched-string nil)
+ (rest-string nil)
+ (ordnum nil))
+ (do ((layers (get-layers loccls) (cdr layers)))
+ ((or give-up
+ (let ((empty-string (= 0 (length locstring)))
+ (empty-list (endp layers)))
+ (cond (empty-string t)
+ (empty-list (setq give-up t))
+ (t nil)))))
+ (let ((curr-layer (car layers)))
+ (multiple-value-setq (matched-string rest-string ordnum)
+ (prefix-match locstring curr-layer))
+ (cond ((eq ordnum nil) (setq give-up t))
+ ((numberp ordnum)
+ (setq locstring rest-string)
+ (setq layer-list
+ (cons matched-string layer-list))
+ (setq ordnum-list (cons ordnum ordnum-list)))
+ (t (setq locstring rest-string)))
+ ))
+ (if (not give-up)
+ (values (nreverse layer-list) (nreverse ordnum-list))
+ (values nil nil))))
+;; line 482 "locclass.nw"
+;; FIXME (do we need this)
+;;(defmethod perform-match ((locstring string)
+;; (loccls crossref-location-class))
+;; t)
+
+;; line 507 "locclass.nw"
+(eval-when (compile load eval)
+
+;; line 94 "locclass.nw"
+(export '(location-class perform-match
+ get-name get-ordnum set-ordnum ordnum))
+;; line 112 "locclass.nw"
+(export '(layered-location-class))
+;; line 150 "locclass.nw"
+(export '(standard-location-class checked-make-standard-location-class
+ get-join-length set-join-length
+ joining-allowed-p join-length))
+;; line 177 "locclass.nw"
+(export '(var-location-class checked-make-var-location-class))
+;; line 197 "locclass.nw"
+(export '(loccls-layer make-loccls-layer
+ get-basetype get-markup))
+;; line 228 "locclass.nw"
+(export '(loccls-separator make-loccls-separator
+ get-separator get-markup))
+;; line 278 "locclass.nw"
+(export '(crossref-location-class get-target))
+;; line 307 "locclass.nw"
+(export '(verified-crossref-location-class
+ make-verified-crossref-location-class))
+;; line 327 "locclass.nw"
+(export '(unverified-crossref-location-class
+ make-unverified-crossref-location-class))
+;; line 183 "locref.nw"
+(export '(crossref-location-reference create-cross-reference))
+;; line 215 "locref.nw"
+(export 'build-location-reference)
+;; line 509 "locclass.nw"
+ )
+;; line 56 "locref.nw"
+(defclass location-reference ()
+ ((locclass :initarg :locclass)
+ (attribute :initarg :attribute)))
+;; line 78 "locref.nw"
+(defclass layered-location-reference (location-reference)
+ ((layers :initarg :layers)
+ (locref-string :initarg :string :type string)
+ (ordnums :initarg :ordnums)
+ (catattr :initarg :catattr)
+ (state :initarg :state)
+ (rangeattr :initform 'nil)
+ (origin :initform 'nil)
+ (subrefs :initform '() :type list)))
+
+;; line 95 "locref.nw"
+(defun make-layered-location-reference (&key (string "")
+ (layers '()) (ordnums '())
+ (catattr nil) (locclass nil)
+ (attribute nil) (virtual nil))
+ (make-instance 'layered-location-reference
+ :string string
+ :layers layers
+ :ordnums ordnums
+ :catattr catattr
+ :locclass locclass
+ :attribute attribute
+ :state (if virtual 'locref-state-virtual
+ 'locref-state-normal)))
+;; line 116 "locref.nw"
+(defmacro state-normal-p (locref)
+ `(EQL 'LOCREF-STATE-NORMAL (SLOT-VALUE ,locref 'STATE)))
+
+(defmacro state-virtual-p (locref)
+ `(EQL 'LOCREF-STATE-VIRTUAL (SLOT-VALUE ,locref 'STATE)))
+
+(defmacro state-deleted-p (locref)
+ `(EQL 'LOCREF-STATE-DELETED (SLOT-VALUE ,locref 'STATE)))
+
+(defun set-state-normal (locref)
+ (set-state 'locref-state-normal locref)
+ locref)
+
+(defun set-state-virtual (locref)
+ (set-state 'locref-state-virtual locref)
+ locref)
+
+(defun set-state-deleted (locref)
+ (set-state 'locref-state-deleted locref)
+ locref)
+;; line 139 "locref.nw"
+(defmacro rangeattr-open-p (attr)
+ `(EQL ,attr :RANGEATTR-OPEN))
+
+(defmacro rangeattr-close-p (attr)
+ `(EQL ,attr :RANGEATTR-CLOSE))
+
+(defmacro set-rangeattr-open (locref)
+ `(SETF (SLOT-VALUE ,locref 'RANGEATTR) :RANGEATTR-OPEN))
+
+(defmacro set-rangeattr-close (locref)
+ `(SETF (SLOT-VALUE ,locref 'RANGEATTR) :RANGEATTR-CLOSE))
+;; line 241 "locref.nw"
+(defclass category-attribute ()
+ ((name :initarg :name)
+ (catattr-grp-ordnum :initarg :ordnum)
+ (sort-ordnum :initform 0)
+ (processing-ordnum :initform 0)
+ (last-in-group :initarg :type)))
+
+(defun make-category-attribute (attr-name)
+ (make-instance 'category-attribute :name attr-name))
+;; line 174 "locref.nw"
+(defclass crossref-location-reference (location-reference)
+ ((target :initarg :target)))
+
+(defun create-cross-reference (loccls target attribute)
+ (make-instance 'crossref-location-reference
+ :locclass loccls :target target :attribute attribute))
+;; line 201 "locref.nw"
+(defmethod build-location-reference ((locclass layered-location-class)
+ (locref-str string)
+ (catattr category-attribute)
+ attribute)
+ (multiple-value-bind (layers ordnums)
+ (perform-match locref-str locclass)
+ (and layers ordnums
+ (make-layered-location-reference
+ :locclass locclass :layers layers
+ :ordnums ordnums :catattr catattr
+ :attribute attribute :string locref-str))))
+;; line 288 "locref.nw"
+(defun locref-class< (locref-1 locref-2)
+ (declare (inline))
+ (< (get-ordnum (get-locclass locref-1))
+ (get-ordnum (get-locclass locref-2))))
+
+(defun locref-class= (locref-1 locref-2)
+ (declare (inline))
+ (eql (get-locclass locref-1) (get-locclass locref-2)))
+;; line 301 "locref.nw"
+(defmacro locref-ordnum< (ordnum-list-1 ordnum-list-2)
+ `(COND
+ ((EQUAL ,ordnum-list-1 ,ordnum-list-2) NIL)
+ (T (DO ((REST-1 ,ordnum-list-1 (CDR REST-1))
+ (REST-2 ,ordnum-list-2 (CDR REST-2)))
+ ((OR (ENDP REST-1) (ENDP REST-2)
+ (/= (FIRST REST-1) (FIRST REST-2)))
+ (COND ((ENDP REST-1) T)
+ ((ENDP REST-2) NIL)
+ (T (< (FIRST REST-1) (FIRST REST-2)))))))))
+
+(defmacro locref-ordnum= (ordnum-list-1 ordnum-list-2)
+ `(EQUAL ,ordnum-list-1 ,ordnum-list-2))
+;; line 320 "locref.nw"
+#|
+FIXME
+(defun locref< (locref-1 locref-2)
+ (cond ((locref-class= locref-1 locref-2)
+ (locref-ordnum< locref-1 locref-2))
+ (t (locref-class< locref-1 locref-2))))
+|#
+
+(defmethod locref= ((locref-1 crossref-location-reference)
+ (locref-2 layered-location-reference))
+ nil)
+
+(defmethod locref= ((locref-1 layered-location-reference)
+ (locref-2 crossref-location-reference))
+ nil)
+
+(defmethod locref= ((locref-1 crossref-location-reference)
+ (locref-2 crossref-location-reference))
+ (and (locref-class= locref-1 locref-2)
+ (equal (get-target locref-1) (get-target locref-2))))
+
+(defmethod locref= ((locref-1 layered-location-reference)
+ (locref-2 layered-location-reference))
+ (and (locref-class= locref-1 locref-2)
+ (eql (get-catattr locref-1) (get-catattr locref-2))
+ (locref-ordnum= (get-ordnums locref-1) (get-ordnums locref-2))
+ (eql (get-rangeattr locref-1) (get-rangeattr locref-2))))
+
+;; line 391 "locref.nw"
+(eval-when (compile load eval)
+
+;; line 62 "locref.nw"
+(export 'location-reference)
+;; line 153 "locref.nw"
+(export '(layered-location-reference
+ make-layered-location-reference
+ get-layers set-layers layers
+ get-ordnums set-ordnums ordnums
+ get-subrefs set-subrefs subrefs
+ get-catattr catattr
+ get-rangeattr rangeattr
+ get-locref-string string
+ get-origin set-origin
+ state
+ state-normal-p state-virtual-p state-deleted-p
+ set-state-normal set-state-virtual set-state-deleted
+ set-rangeattr-open set-rangeattr-close
+ rangeattr-open-p rangeattr-close-p))
+;; line 257 "locref.nw"
+(export '(category-attribute make-category-attribute
+ get-name catattr-grp-ordnum
+ get-catattr-grp-ordnum set-catattr-grp-ordnum
+ get-sort-ordnum set-sort-ordnum
+ get-processing-ordnum set-processing-ordnum
+ get-last-in-group set-last-in-group
+ get-type set-type
+ get-markup set-markup))
+;; line 350 "locref.nw"
+(export '(locref-class< locref-class=
+ locref-ordnum< locref-ordnum=
+ locref=))
+;; line 393 "locref.nw"
+ )
+
+;; line 521 "locclass.nw"
+#+:XP
+(set-pprint-dispatch 'location-class
+ #'(lambda (s loccls)
+ (pprint-logical-block
+ (s nil :prefix "{" :suffix "}")
+ (write (get-name loccls) :stream s)
+ (write-string ":" s)
+ (write (get-ordnum loccls) :stream s))))
+
+#+:XP
+(set-pprint-dispatch 'layered-location-class
+ #'(lambda (s loccls)
+ (pprint-logical-block
+ (s nil :prefix "{" :suffix "}")
+ (write (get-name loccls) :stream s)
+ (write-string ":" s)
+ (write (get-ordnum loccls) :stream s)
+ (mapc #'(lambda (x)
+ (write-string " " s)
+ (pprint x s))
+ (get-layers loccls)))))
+
+#+:XP
+(set-pprint-dispatch 'loccls-layer
+ #'(lambda (s layer)
+ (pprint-logical-block
+ (s nil :prefix "<" :suffix ">")
+ (pprint (get-basetype layer) s))))
+
+#+:XP
+(set-pprint-dispatch 'loccls-separator
+ #'(lambda (s sep)
+ (pprint-logical-block
+ (s nil :prefix "<" :suffix ">")
+ (write (get-separator sep) :stream s))))
+;; line 406 "locref.nw"
+#+:XP
+(defun pprint-layered-location-reference (s locref)
+ (pprint-logical-block
+ (s nil :prefix "[" :suffix "]")
+ (cond ((state-normal-p locref) (write-string "Nor:" s))
+ ((state-virtual-p locref) (write-string "Vir:" s))
+ (t (write-string "Del:" s)))
+ (cond ((rangeattr-open-p (get-rangeattr locref)) (write-string "OPEN:" s))
+ ((rangeattr-close-p (get-rangeattr locref)) (write-string "CLOSE:" s)))
+ (write-string "\"" s)
+ (write-string (get-locref-string locref) s)
+ (write-string "\"=" s)
+ (write (get-layers locref) :stream s)
+ (write-string "=" s)
+ (write (get-ordnums locref) :stream s)
+ (write-string ";" s)
+ (pprint-newline :fill s)
+ (write (get-locclass locref) :stream s)
+ (write-string ";" s)
+ (pprint-newline :fill s)
+ (write (get-catattr locref) :stream s)
+ (when (get-origin locref)
+ (write-string "<-" s)
+ (write (get-catattr (get-origin locref)) :stream s))
+ (pprint-newline :fill s)
+ (write (get-subrefs locref) :stream s)
+ ))
+
+#+:XP
+(set-pprint-dispatch 'layered-location-reference
+ #'pprint-layered-location-reference)
+;; line 440 "locref.nw"
+#+:XP
+(defun pprint-crossref-location-reference (s xref)
+ (pprint-logical-block
+ (s nil :prefix "[" :suffix "]")
+ (write (get-locclass xref) :stream s)
+ (write-string "->" s)
+ (write (get-target xref) :stream s)
+ ))
+
+#+:XP
+(set-pprint-dispatch 'crossref-location-reference
+ #'pprint-crossref-location-reference)
+;; line 455 "locref.nw"
+#+:XP
+(set-pprint-dispatch 'category-attribute
+ #'(lambda (s catattr)
+ (write-string "`" s)
+ (write-string (get-name catattr) s)
+ (write-string "'" s)))
+
+;; line 380 "locref.nw"
+(defvar *RCS-Identifier* '(
+;; line 263 "basetype.nw"
+("basetype" . "$Id: basetype.nw,v 1.17 1997/03/26 16:18:47 kehr Exp $")
+;; line 513 "locclass.nw"
+("locclass" . "$Id: locclass.nw,v 1.21 1997/03/26 16:18:49 kehr Exp $")
+;; line 397 "locref.nw"
+("locref" . "$Id: locref.nw,v 1.29 1997/03/26 16:18:53 kehr Exp $")
+;; line 380 "locref.nw"
+ ))
diff --git a/Build/source/utils/xindy/xindy-2.4/src/markup.lsp b/Build/source/utils/xindy/xindy-2.4/src/markup.lsp
new file mode 100644
index 00000000000..c0f696e2a6e
--- /dev/null
+++ b/Build/source/utils/xindy/xindy-2.4/src/markup.lsp
@@ -0,0 +1,1289 @@
+;; line 1154 "markup.nw"
+;; $Id: markup.nw,v 1.24 1997/03/26 16:18:58 kehr Exp $
+
+(lisp:defpackage "MARKUP")
+(lisp:in-package "MARKUP")
+(lisp:provide "markup")
+#+CLISP (lisp:require "base")
+#+CLISP (lisp:require "locref")
+#+CLISP (lisp:require "idxstyle")
+#+CLISP (lisp:require "index")
+#+CLISP (lisp:require "ordrules")
+#+CLISP (lisp:require "version")
+
+(eval-when (compile load eval)
+ (lisp:use-package "CLOS")
+ #+(and :XP CLISP) (lisp:use-package "XP")
+ #+CLISP (setq custom:*suppress-check-redefinition* t)
+ #-CLISP (lisp:require "base")
+ #-CLISP (lisp:require "locref")
+ #-CLISP (lisp:require "idxstyle")
+ #-CLISP (lisp:require "index")
+ (lisp:use-package "BASE")
+ (lisp:use-package "LOCREF")
+ (lisp:use-package "IDXSTYLE")
+ (lisp:use-package "INDEX"))
+
+;; line 1222 "markup.nw"
+;; $Id: markup.nw,v 1.24 1997/03/26 16:18:58 kehr Exp $
+
+;; line 71 "markup.nw"
+(defparameter *markup-output-stream* *standard-output*)
+(defparameter *markup-verbose-mode* nil)
+(defparameter *markup-verbose-open* "<")
+(defparameter *markup-verbose-close* ">")
+(defparameter *markup-indentation* 2)
+(defparameter *markup-indent-level* 0)
+(defparameter *empty-markup* "")
+
+(defvar *markup-percentage-list*)
+(defvar *current-number*)
+
+(defun do-markup-indent ()
+ (incf *markup-indent-level* *markup-indentation*))
+(defun do-markup-outdent ()
+ (decf *markup-indent-level* *markup-indentation*))
+;; line 102 "markup.nw"
+(defun do-markup-string (str)
+ (declare (inline))
+ (write-string str *markup-output-stream*))
+;; line 111 "markup.nw"
+(defun do-markup-default (str &optional arg1 arg2 arg3)
+ (when *markup-verbose-mode*
+ (loop for x from 1 to *markup-indent-level*
+ do (write-string " " *markup-output-stream*))
+ (do-markup-string *markup-verbose-open*)
+ (do-markup-string str)
+ (when arg1
+ (format *markup-output-stream* " [~S]" arg1)
+ (when arg2
+ (format *markup-output-stream* " [~S]" arg2)
+ (when arg3
+ (format *markup-output-stream* " [~S]" arg3)
+ )))
+ (do-markup-string *markup-verbose-close*)
+ (terpri *markup-output-stream*)
+ ))
+;; line 138 "markup.nw"
+(defmacro do-markup-list (some-list
+ &key
+ identifier counter
+ elt-body sep-body
+ open-body close-body)
+ `(PROGN
+ ,(when open-body `,open-body)
+ (LET ,(if counter
+ `((LIST-END (CAR (LAST ,some-list)))
+ (COUNTER ,counter))
+ `((LIST-END (CAR (LAST ,some-list)))))
+ (DO ((SLIST ,some-list (CDR SLIST)))
+ ((ENDP SLIST))
+ (LET ((,identifier (CAR SLIST)))
+ ,elt-body
+ ,(if sep-body
+ `(UNLESS (EQL ,identifier LIST-END)
+ ,sep-body)))))
+ ,(when close-body close-body)))
+;; line 162 "markup.nw"
+#|
+(macroexpand '(markup-list '(1 2 3) :identifier FOO
+ :open-body (print "open")
+ :close-body (print "close")
+ :elt-body (print FOO)
+ :sep-body (print ",")))
+
+expands to
+
+(PROGN (PRINT "open")
+ (LET ((LIST-END (CAR (LAST '(1 2 3)))))
+ (DO ((SLIST '(1 2 3) (CDR SLIST))) ((ENDP SLIST))
+ (LET ((FOO (CAR SLIST))) (PRINT FOO)
+ (UNLESS (EQL FOO LIST-END) (PRINT ","))
+ ) ) )
+ (PRINT "close")
+) ;
+T
+|#
+;; line 193 "markup.nw"
+(defmacro define-list-environment-methods (name
+ signature
+ &key open close sep declare body)
+ (let ((name (stringify name)))
+ `(EVAL-WHEN (COMPILE LOAD EVAL)
+ (HANDLER-BIND ((WARNING #'MUFFLE-WARNING))
+ (CL:DEFMETHOD
+ ,(intern (string-upcase (concatenate 'string name "-open"))
+ 'markup)
+ ,signature ,@declare ,@open ,@body)
+ (CL:DEFMETHOD
+ ,(intern (string-upcase (concatenate 'string name "-close"))
+ 'markup)
+ ,signature ,@declare ,@close ,@body)
+ (CL:DEFMETHOD
+ ,(intern (string-upcase (concatenate 'string name "-sep"))
+ 'markup)
+ ,signature ,@declare ,@sep ,@body)))))
+;; line 214 "markup.nw"
+(defmacro define-environment-methods (name
+ signature
+ &key open close declare body)
+ (let ((name (stringify name)))
+ `(EVAL-WHEN (COMPILE LOAD EVAL)
+ (HANDLER-BIND ((WARNING #'MUFFLE-WARNING))
+ (CL:DEFMETHOD
+ ,(intern (string-upcase (concatenate 'string name "-open"))
+ 'markup)
+ ,signature ,@declare ,@open ,@body)
+ (CL:DEFMETHOD
+ ,(intern (string-upcase (concatenate 'string name "-close"))
+ 'markup)
+ ,signature ,@declare ,@close ,@body)))))
+
+(defmacro define-method (name
+ signature
+ &key declare body)
+ (let ((name (stringify name)))
+ `(EVAL-WHEN (COMPILE LOAD EVAL)
+ (HANDLER-BIND ((WARNING #'MUFFLE-WARNING))
+ (CL:DEFMETHOD
+ ,(intern (string-upcase name) 'markup)
+ ,signature ,@declare ,@body)))))
+;; line 326 "markup.nw"
+(defmethod do-markup-index ((idx base-index))
+ (setq *current-number* 0)
+ (setq *markup-percentage-list* index:*percentage-list*)
+ (do-markup-index-open idx)
+ (do-markup-list (get-entries idx)
+ :identifier LETTER-GRP
+ :open-body (do-markup-letter-group-list-open)
+ :elt-body (do-markup-letter-group LETTER-GRP)
+ :sep-body (do-markup-letter-group-list-sep)
+ :close-body (do-markup-letter-group-list-close))
+ (index:print-rest-of-percentages *markup-percentage-list*)
+ (do-markup-index-close idx))
+
+(define-environment-methods do-markup-index ((idx base-index))
+ :open ((do-markup-default "INDEX:OPEN")
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "INDEX:CLOSE")))
+;; line 351 "markup.nw"
+(defmacro markup-index (&whole whole &rest args)
+ (destructuring-switch-bind (&key
+ open close hierdepth
+ &switch
+ tree flat)
+ args
+ (let (hierdepth-cmd)
+ (when (or hierdepth tree flat)
+ (cond
+ ((and tree flat)
+ (error "you can't specify :tree and :flat simultaneously in ~%~S~%"
+ whole))
+ ((and hierdepth (or tree flat))
+ (error "you can't specify :hierdepth with :tree or :flat simultaneously in ~%~S~%"
+ whole))
+ (flat (setq hierdepth-cmd
+ `(SET-HIERDEPTH 0 *INDEX*)));; no tree-structure
+ ;; MOST-POSITIVE-FIXNUM means make all trees
+ (tree (setq hierdepth-cmd
+ `(SET-HIERDEPTH MOST-POSITIVE-FIXNUM *INDEX*)))
+ (hierdepth
+ (when (not (numberp hierdepth))
+ (error "~S is not a number in ~S~%" whole))
+ (setq hierdepth-cmd
+ `(SET-HIERDEPTH ,hierdepth *INDEX*))))
+ `(LET ()
+ (markup::define-environment-methods
+ DO-MARKUP-INDEX ((idx index:base-index))
+ :declare ((declare (ignore idx)))
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close))))
+ ,hierdepth-cmd)))))
+;; line 390 "markup.nw"
+(define-list-environment-methods do-markup-letter-group-list ()
+ :open ((do-markup-default "LETTER-GROUP-LIST:OPEN")
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "LETTER-GROUP-LIST:CLOSE"))
+ :sep ((do-markup-default "LETTER-GROUP-LIST:SEP")))
+;; line 409 "markup.nw"
+(defmethod do-markup-letter-group ((letter-grp letter-group))
+ (let ((group-definition (get-group-definition letter-grp)))
+ (do-markup-letter-group-open group-definition)
+ (do-markup-letter-group-head-open group-definition)
+ (do-markup-letter-group-head group-definition)
+ (do-markup-letter-group-head-close group-definition)
+ (do-markup-list (get-members letter-grp)
+ :identifier IDXENT #| the identifier to use in the expansion |#
+ :open-body (do-markup-indexentry-list-open 0
+ #|initial depth:=0|#)
+ :elt-body (do-markup-indexentry IDXENT 0)
+ :sep-body (do-markup-indexentry-list-sep 0)
+ :close-body (do-markup-indexentry-list-close 0))
+ (do-markup-letter-group-close group-definition)))
+
+(define-environment-methods do-markup-letter-group
+ ((group letter-group-definition))
+ :open ((do-markup-default "LETTER-GROUP:OPEN" (get-name group))
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "LETTER-GROUP:CLOSE" (get-name group))))
+
+(define-environment-methods do-markup-letter-group-head
+ ((group letter-group-definition))
+ :open ((do-markup-default "LETTER-GROUP-HEAD:OPEN" (get-name group))
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "LETTER-GROUP-HEAD:CLOSE" (get-name group))))
+
+(define-method do-markup-letter-group-head ((group letter-group-definition))
+ :body ((do-markup-default "LETTER-GROUP-HEAD" (get-name group))))
+;; line 503 "markup.nw"
+(define-list-environment-methods do-markup-indexentry-list ((depth number))
+ :open ((do-markup-default "INDEXENTRY-LIST:OPEN" depth)
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "INDEXENTRY-LIST:CLOSE" depth))
+ :sep ((do-markup-default "INDEXENTRY-LIST:SEP" depth)))
+;; line 525 "markup.nw"
+(defmethod do-markup-indexentry ((idxent index-entry)
+ (depth number))
+ (when (>= (incf *current-number*) (caar *markup-percentage-list*))
+ (index:print-percent (pop *markup-percentage-list*)))
+
+ (do-markup-indexentry-open depth)
+
+ (let ((print-key (get-print-key idxent)))
+ (do-markup-list (merge-print-and-main-key print-key (get-main-key idxent))
+ :identifier KEYWORD
+ :open-body (do-markup-keyword-list-open depth)
+ :elt-body (do-markup-keyword KEYWORD depth)
+ :sep-body (do-markup-keyword-list-sep depth)
+ :close-body (do-markup-keyword-list-close depth)))
+
+ (let ((locrefs (get-locrefs idxent)))
+ (unless (endp locrefs)
+ (do-markup-list locrefs
+ :identifier LOCCLS-GRP
+ :open-body (do-markup-locclass-list-open)
+ :elt-body (do-markup-locclass LOCCLS-GRP)
+ :sep-body (do-markup-locclass-list-sep)
+ :close-body (do-markup-locclass-list-close))))
+
+ (let ((subentries (get-subentries idxent)))
+ (unless (endp subentries)
+ (let ((new-depth (1+ depth)))
+ (do-markup-list subentries
+ :identifier IDXENT
+ :open-body (do-markup-indexentry-list-open new-depth)
+ :elt-body (do-markup-indexentry IDXENT new-depth)
+ :sep-body (do-markup-indexentry-list-sep new-depth)
+ :close-body (do-markup-indexentry-list-close new-depth)))))
+
+ (do-markup-indexentry-close depth))
+
+(defun merge-print-and-main-key (print-key main-key)
+ ;;(info "~&(merge-print-and-main-key ~S ~S)" print-key main-key)
+ (if print-key
+ (mapcar #'(lambda (print main)
+ (or print main))
+ print-key main-key)
+ main-key))
+;; line 571 "markup.nw"
+(define-environment-methods do-markup-indexentry ((depth number))
+ :open ((do-markup-default "INDEXENTRY:OPEN" depth)
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "INDEXENTRY:CLOSE" depth)))
+;; line 595 "markup.nw"
+(define-list-environment-methods do-markup-keyword-list ((depth number))
+ :open ((do-markup-default "KEYWORD-LIST:OPEN" depth)
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "KEYWORD-LIST:CLOSE" depth))
+ :sep ((do-markup-default "KEYWORD-LIST:SEP" depth)))
+;; line 617 "markup.nw"
+(defmethod do-markup-keyword (keyword (depth number))
+ (do-markup-keyword-open depth)
+ (do-markup-string keyword)
+ (do-markup-keyword-close depth))
+;; line 624 "markup.nw"
+(define-environment-methods do-markup-keyword ((depth number))
+ :open ((do-markup-default "KEYWORD:OPEN" depth)
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "KEYWORD:CLOSE" depth)))
+;; line 654 "markup.nw"
+(define-list-environment-methods do-markup-locclass-list ()
+ :open ((do-markup-default "LOCCLASS-LIST:OPEN")
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "LOCCLASS-LIST:CLOSE"))
+ :sep ((do-markup-default "LOCCLASS-LIST:SEP")))
+;; line 677 "markup.nw"
+(defmethod do-markup-locclass ((locref-cls-grp locref-class-group))
+ (let ((locclass (get-locclass locref-cls-grp)))
+ (do-markup-locref-class-open locclass)
+
+ (do-markup-list (get-members locref-cls-grp)
+ :identifier ATTRIBUTE-GRP
+ :open-body (do-markup-attribute-group-list-open)
+ :elt-body (do-markup-attribute-group ATTRIBUTE-GRP locclass)
+ :sep-body (do-markup-attribute-group-list-sep)
+ :close-body (do-markup-attribute-group-list-close))
+
+ (do-markup-locref-class-close locclass)))
+
+(define-environment-methods do-markup-locref-class
+ ((locrefcls layered-location-class))
+ :open ((do-markup-default "LOCREF-CLASS:OPEN" (get-name locrefcls))
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "LOCREF-CLASS:CLOSE" (get-name locrefcls))))
+;; line 1044 "markup.nw"
+(defmethod do-markup-locclass ((xref-cls-grp crossref-class-group))
+ (let ((xrefclass (get-locclass xref-cls-grp)))
+
+ (do-markup-list (get-members xref-cls-grp)
+ :identifier XREF
+ :open-body (do-markup-crossref-list-open xrefclass)
+ :elt-body (do-markup-crossref XREF)
+ :sep-body (do-markup-crossref-list-sep xrefclass)
+ :close-body (do-markup-crossref-list-close xrefclass))))
+
+(define-list-environment-methods do-markup-crossref-list
+ ((xrefclass crossref-location-class))
+ :open ((do-markup-default "CROSSREF-LIST:OPEN" (get-name xrefclass))
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "CROSSREF-LIST:CLOSE" (get-name xrefclass)))
+ :sep ((do-markup-default "CROSSREF-LIST:SEP" (get-name xrefclass))))
+;; line 1080 "markup.nw"
+(defmethod do-markup-crossref ((xref crossref-location-reference))
+ (let ((xrefclass (get-locclass xref)))
+
+ (do-markup-list (get-target xref)
+ :identifier XREF-LAYER
+ :open-body (do-markup-crossref-layer-list-open xrefclass)
+ :elt-body (do-markup-crossref-layer XREF-LAYER xrefclass)
+ :sep-body (do-markup-crossref-layer-list-sep xrefclass)
+ :close-body (do-markup-crossref-layer-list-close xrefclass))))
+
+(define-list-environment-methods do-markup-crossref-layer-list
+ ((xref-class crossref-location-class))
+ :open ((do-markup-default "CROSSREF-LAYER-LIST:OPEN"
+ (get-name xref-class))
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "CROSSREF-LAYER-LIST:CLOSE"
+ (get-name xref-class)))
+ :sep ((do-markup-default "CROSSREF-LAYER-LIST:SEP"
+ (get-name xref-class))))
+;; line 1119 "markup.nw"
+(defmethod do-markup-crossref-layer (xref-layer
+ (xref-class crossref-location-class))
+ (do-markup-crossref-layer-open xref-class)
+ (do-markup-string xref-layer)
+ (do-markup-crossref-layer-close xref-class))
+
+(define-environment-methods do-markup-crossref-layer
+ ((xref-class crossref-location-class))
+ :open ((do-markup-default "CROSSREF-LAYER:OPEN" (get-name xref-class))
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "CROSSREF-LAYER:CLOSE" (get-name xref-class))))
+;; line 718 "markup.nw"
+(define-list-environment-methods do-markup-attribute-group-list ()
+ :open ((do-markup-default "ATTRIBUTE-GROUP-LIST:OPEN")
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "ATTRIBUTE-GROUP-LIST:CLOSE"))
+ :sep ((do-markup-default "ATTRIBUTE-GROUP-LIST:SEP")))
+;; line 737 "markup.nw"
+(defmethod do-markup-attribute-group ((attribute-group category-attribute-group)
+ (loccls layered-location-class))
+ (let ((ordnum (get-ordnum attribute-group)))
+ (do-markup-attribute-group-open ordnum)
+
+ (do-markup-list (get-members attribute-group)
+ :identifier LOCREF
+ :open-body (do-markup-locref-list-open loccls 0)
+ :elt-body (do-markup-locref LOCREF loccls 0)
+ :sep-body (do-markup-locref-list-sep loccls 0)
+ :close-body (do-markup-locref-list-close loccls 0))
+
+ (do-markup-attribute-group-close ordnum)))
+
+(define-environment-methods do-markup-attribute-group ((ordnum number))
+ :open ((do-markup-default "ATTRIBUTE-GROUP:OPEN" ordnum)
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "ATTRIBUTE-GROUP:CLOSE" ordnum)))
+;; line 776 "markup.nw"
+(define-list-environment-methods do-markup-locref-list
+ ((loccls layered-location-class) (depth number))
+ :open ((do-markup-default "LOCREF-LIST:OPEN" (get-name loccls) depth)
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "LOCREF-LIST:CLOSE" (get-name loccls) depth))
+ :sep ((do-markup-default "LOCREF-LIST:SEP" (get-name loccls) depth)))
+;; line 808 "markup.nw"
+(defmethod do-markup-locref ((locref location-reference)
+ (loccls layered-location-class)
+ (depth number))
+ #+ASSERT! (assert! (and (typep locref 'layered-location-reference)
+ (typep depth 'number)))
+ (let ((attr (get-catattr locref))
+ (subrefs (get-subrefs locref))
+ (new-depth (1+ depth)))
+
+ (do-markup-locref-open attr loccls depth)
+
+ (cond
+ (subrefs
+ (let ((layer 0))
+ (do-markup-list (get-layers locref)
+ :identifier LOCREF-LAYER
+ :open-body (do-markup-locref-layer-list-open loccls depth)
+ :elt-body (do-markup-locref-layer LOCREF-LAYER loccls depth
+ (prog1 layer
+ (incf layer)))
+ :sep-body (do-markup-locref-layer-list-sep loccls depth)
+ :close-body (do-markup-locref-layer-list-close loccls depth)))
+
+ (do-markup-list subrefs
+ :identifier LOCREF
+ :open-body (do-markup-locref-list-open loccls new-depth)
+ :elt-body (do-markup-locref LOCREF loccls new-depth)
+ :sep-body (do-markup-locref-list-sep loccls new-depth)
+ :close-body (do-markup-locref-list-close loccls new-depth)))
+
+ ((= 0 depth)
+ (do-markup-string (get-locref-string locref)))
+
+ (t (let ((layer 0))
+ (do-markup-list (get-layers locref)
+ :identifier LOCREF-LAYER
+ :open-body (do-markup-locref-layer-list-open loccls depth)
+ :elt-body (do-markup-locref-layer LOCREF-LAYER loccls depth
+ (prog1 layer
+ (incf layer)))
+ :sep-body (do-markup-locref-layer-list-sep loccls depth)
+ :close-body (do-markup-locref-layer-list-close loccls depth)))))
+
+ (do-markup-locref-close attr loccls depth)))
+;; line 855 "markup.nw"
+(define-list-environment-methods do-markup-locref-layer-list
+ ((loccls layered-location-class) (depth number))
+ :open ((do-markup-default "LOCREF-LAYER-LIST:OPEN" (get-name loccls) depth)
+ (do-markup-indent))
+ :sep ((do-markup-default "LOCREF-LAYER-LIST:SEP" (get-name loccls) depth))
+ :close ((do-markup-outdent)
+ (do-markup-default "LOCREF-LAYER-LIST:CLOSE" (get-name loccls) depth)))
+;; line 883 "markup.nw"
+(defun do-markup-locref-layer (locref-layer loccls depth layer)
+ (do-markup-locref-layer-open loccls depth layer)
+ (do-markup-string locref-layer)
+ (do-markup-locref-layer-close loccls depth layer))
+
+(define-environment-methods do-markup-locref-layer
+ ((locref-class layered-location-class) (depth number) (layer number))
+ :open ((do-markup-default "LOCREF-LAYER:OPEN"
+ (get-name locref-class) depth layer)
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "LOCREF-LAYER:CLOSE"
+ (get-name locref-class) depth layer)))
+;; line 918 "markup.nw"
+(define-environment-methods do-markup-locref ((attr category-attribute)
+ (loccls layered-location-class)
+ (depth number))
+ :open ((do-markup-default "LOCREF:OPEN"
+ (get-name attr) (get-name loccls) depth)
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "LOCREF:CLOSE"
+ (get-name attr) (get-name loccls) depth)))
+;; line 955 "markup.nw"
+(defmethod do-markup-locref ((range location-range)
+ (loccls layered-location-class)
+ (depth number))
+ (let ((length (get-length range)))
+ (do-markup-range-open loccls length)
+ (do-markup-locref (get-first range) loccls depth)
+ (do-markup-range-sep loccls length)
+ (when (markup-range-print-end-p loccls length)
+ (do-markup-locref (get-last range) loccls depth))
+ (do-markup-range-close loccls length)))
+
+(define-list-environment-methods do-markup-range
+ ((loccls layered-location-class) (length number))
+ :open ((do-markup-default "RANGE:OPEN" (get-name loccls) length)
+ (do-markup-indent))
+ :close ((do-markup-outdent)
+ (do-markup-default "RANGE:CLOSE" (get-name loccls) length))
+ :sep ((do-markup-default "RANGE:SEP" (get-name loccls) length)))
+
+(defmethod markup-range-print-end-p ((loccls layered-location-class)
+ (length number))
+ t)
+;; line 304 "markup.nw"
+(defmacro markup-trace (&rest args)
+ (destructuring-switch-bind (&key
+ (open *markup-verbose-open*)
+ (close *markup-verbose-close*)
+ &switch
+ on)
+ args
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 312 "markup.nw"
+ (t `(LET ()
+ (SETQ *markup-verbose-open* ,open)
+ (SETQ *markup-verbose-close* ,close)
+ ,(when on `(SETQ *markup-verbose-mode* t)))))))
+;; line 399 "markup.nw"
+(defmacro markup-letter-group-list (&key open close sep)
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 260 "markup.nw"
+((and sep (not (stringp sep)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" sep))
+;; line 401 "markup.nw"
+ (t `(markup::define-list-environment-methods
+ DO-MARKUP-LETTER-GROUP-LIST ()
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))
+ :sep ,(when sep `((do-markup-string ,sep)))))))
+;; line 443 "markup.nw"
+(defmacro markup-letter-group (&whole whole &rest args)
+ (destructuring-switch-bind (&key
+ open close group
+ open-head close-head
+ &switch
+ upcase downcase capitalize)
+ args
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 451 "markup.nw"
+
+;; line 252 "markup.nw"
+((and open-head (not (stringp open-head)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open-head))
+((and close-head (not (stringp close-head)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close-head))
+;; line 452 "markup.nw"
+
+;; line 275 "markup.nw"
+((and group (progn
+ (setq group (stringify group))
+ (not (lookup-letter-group-definition *indexstyle* group))))
+ (nraw "parameter `~S' is not a valid letter-group! (ignored)~%" group))
+;; line 453 "markup.nw"
+ ((or (and upcase downcase)
+ (and upcase capitalize)
+ (and downcase capitalize))
+ (error "more than one modifier in~%~S" whole))
+ (t `(LET ()
+ (markup::define-environment-methods
+ DO-MARKUP-LETTER-GROUP
+ (,(if group
+ `(lg-def (EQL ',(lookup-letter-group-definition
+ *indexstyle* group)))
+ '(lg-def letter-group-definition)))
+ :declare ((declare (ignore lg-def)))
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close))))
+ (markup::define-environment-methods
+ DO-MARKUP-LETTER-GROUP-HEAD
+ (,(if group
+ `(lg-def (EQL ',(lookup-letter-group-definition
+ *indexstyle* group)))
+ '(lg-def letter-group-definition)))
+ :declare ((declare (ignore lg-def)))
+ :open ,(when open-head `((do-markup-string ,open-head)))
+ :close ,(when close-head `((do-markup-string ,close-head))))
+ ,(when (or open-head close-head)
+ `(markup::define-method
+ DO-MARKUP-LETTER-GROUP-HEAD
+ (,(if group
+ `(lg-def (EQL ',(lookup-letter-group-definition
+ *indexstyle* group)))
+ '(lg-def letter-group-definition)))
+ :body ((do-markup-string
+ ,(cond (upcase `(string-upcase
+ (get-name lg-def)))
+ (downcase `(string-downcase
+ (get-name lg-def)))
+ (capitalize `(string-capitalize
+ (get-name lg-def)))
+ (t `(get-name lg-def))))))))))))
+;; line 512 "markup.nw"
+(defmacro markup-indexentry-list (&key open close sep depth)
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 260 "markup.nw"
+((and sep (not (stringp sep)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" sep))
+;; line 514 "markup.nw"
+
+;; line 265 "markup.nw"
+((and depth (not (integerp depth)))
+ (nraw "parameter `~S' is not a number! (ignored)~%" depth))
+;; line 515 "markup.nw"
+ (t `(markup::define-list-environment-methods
+ DO-MARKUP-INDEXENTRY-LIST
+ (,(if depth `(depth (EQL ,depth)) '(depth number)))
+ :declare ((declare (ignore depth)))
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))
+ :sep ,(when sep `((do-markup-string ,sep)))))))
+;; line 579 "markup.nw"
+(defmacro markup-indexentry (&key open close depth)
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 581 "markup.nw"
+
+;; line 265 "markup.nw"
+((and depth (not (integerp depth)))
+ (nraw "parameter `~S' is not a number! (ignored)~%" depth))
+;; line 582 "markup.nw"
+ (t `(markup::define-environment-methods
+ DO-MARKUP-INDEXENTRY
+ (,(if depth `(depth (EQL ,depth)) '(depth number)))
+ :declare ((declare (ignore depth)))
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))))))
+;; line 604 "markup.nw"
+(defmacro markup-keyword-list (&key open close sep depth)
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 260 "markup.nw"
+((and sep (not (stringp sep)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" sep))
+;; line 606 "markup.nw"
+
+;; line 265 "markup.nw"
+((and depth (not (integerp depth)))
+ (nraw "parameter `~S' is not a number! (ignored)~%" depth))
+;; line 607 "markup.nw"
+ (t `(markup::define-list-environment-methods
+ DO-MARKUP-KEYWORD-LIST
+ (,(if depth `(depth (EQL ,depth)) '(depth number)))
+ :declare ((declare (ignore depth)))
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))
+ :sep ,(when sep `((do-markup-string ,sep)))))))
+;; line 632 "markup.nw"
+(defmacro markup-keyword (&key open close depth)
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 634 "markup.nw"
+
+;; line 265 "markup.nw"
+((and depth (not (integerp depth)))
+ (nraw "parameter `~S' is not a number! (ignored)~%" depth))
+;; line 635 "markup.nw"
+ (t `(markup::define-environment-methods
+ DO-MARKUP-KEYWORD
+ (,(if depth `(depth (EQL ,depth)) '(depth number)))
+ :declare ((declare (ignore depth)))
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))))))
+;; line 663 "markup.nw"
+(defmacro markup-locclass-list (&key open close sep)
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 260 "markup.nw"
+((and sep (not (stringp sep)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" sep))
+;; line 665 "markup.nw"
+ (t `(markup::define-list-environment-methods
+ DO-MARKUP-LOCCLASS-LIST ()
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))
+ :sep ,(when sep `((do-markup-string ,sep)))))))
+;; line 699 "markup.nw"
+(defmacro markup-locref-class (&key open close class)
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 701 "markup.nw"
+
+;; line 282 "markup.nw"
+((and class (progn (setq class (stringify class))
+ (not (lookup-locref-class *indexstyle* class))))
+ (nraw "parameter `~S' is not a location-reference class! (ignored)~%" class))
+;; line 702 "markup.nw"
+ (t `(markup::define-list-environment-methods
+ DO-MARKUP-LOCREF-CLASS
+ (,(if class
+ `(locrefcls (EQL ',(cdr (lookup-locref-class
+ *indexstyle* class))))
+ '(locrefcls layered-location-class)))
+ :declare ((declare (ignore locrefcls)))
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))))))
+;; line 727 "markup.nw"
+(defmacro markup-attribute-group-list (&key open close sep)
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 260 "markup.nw"
+((and sep (not (stringp sep)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" sep))
+;; line 729 "markup.nw"
+ (t `(markup::define-list-environment-methods
+ DO-MARKUP-ATTRIBUTE-GROUP-LIST ()
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))
+ :sep ,(when sep `((do-markup-string ,sep)))))))
+;; line 759 "markup.nw"
+(defmacro markup-attribute-group (&key open close group)
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 761 "markup.nw"
+
+;; line 275 "markup.nw"
+((and group (progn
+ (setq group (stringify group))
+ (not (lookup-letter-group-definition *indexstyle* group))))
+ (nraw "parameter `~S' is not a valid letter-group! (ignored)~%" group))
+;; line 762 "markup.nw"
+ (t `(markup::define-environment-methods
+ DO-MARKUP-ATTRIBUTE-GROUP
+ (,(if group
+ `(ordnum (EQL ,group))
+ '(ordnum number)))
+ :declare ((declare (ignore ordnum)))
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))))))
+;; line 786 "markup.nw"
+(defmacro markup-locref-list (&key open close sep class depth)
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 260 "markup.nw"
+((and sep (not (stringp sep)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" sep))
+;; line 788 "markup.nw"
+
+;; line 265 "markup.nw"
+((and depth (not (integerp depth)))
+ (nraw "parameter `~S' is not a number! (ignored)~%" depth))
+;; line 789 "markup.nw"
+
+;; line 282 "markup.nw"
+((and class (progn (setq class (stringify class))
+ (not (lookup-locref-class *indexstyle* class))))
+ (nraw "parameter `~S' is not a location-reference class! (ignored)~%" class))
+;; line 790 "markup.nw"
+ (t `(markup::define-list-environment-methods
+ DO-MARKUP-LOCREF-LIST
+ (,(if class
+ `(locrefcls (EQL ',(cdr (lookup-locref-class
+ *indexstyle* class))))
+ '(locrefcls layered-location-class))
+ ,(if depth `(depth (EQL ,depth)) '(depth number)))
+ :declare ((declare (ignore locrefcls depth)))
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))
+ :sep ,(when sep `((do-markup-string ,sep)))))))
+;; line 865 "markup.nw"
+(defmacro markup-locref-layer-list (&key open close sep class depth)
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 260 "markup.nw"
+((and sep (not (stringp sep)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" sep))
+;; line 867 "markup.nw"
+
+;; line 265 "markup.nw"
+((and depth (not (integerp depth)))
+ (nraw "parameter `~S' is not a number! (ignored)~%" depth))
+;; line 868 "markup.nw"
+
+;; line 282 "markup.nw"
+((and class (progn (setq class (stringify class))
+ (not (lookup-locref-class *indexstyle* class))))
+ (nraw "parameter `~S' is not a location-reference class! (ignored)~%" class))
+;; line 869 "markup.nw"
+ (t `(markup::define-list-environment-methods
+ DO-MARKUP-LOCREF-LAYER-LIST
+ (,(if class
+ `(locrefcls (EQL ',(cdr (lookup-locref-class
+ *indexstyle* class))))
+ '(locrefcls layered-location-class))
+ ,(if depth `(depth (EQL ,depth)) '(depth number)))
+ :declare ((declare (ignore locrefcls depth)))
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))
+ :sep ,(when sep `((do-markup-string ,sep)))))))
+;; line 899 "markup.nw"
+(defmacro markup-locref-layer (&key class open close depth layer)
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 901 "markup.nw"
+
+;; line 265 "markup.nw"
+((and depth (not (integerp depth)))
+ (nraw "parameter `~S' is not a number! (ignored)~%" depth))
+;; line 902 "markup.nw"
+
+;; line 270 "markup.nw"
+((and layer (not (integerp layer)))
+ (nraw "parameter `~S' is not a number! (ignored)~%" layer))
+;; line 903 "markup.nw"
+
+;; line 282 "markup.nw"
+((and class (progn (setq class (stringify class))
+ (not (lookup-locref-class *indexstyle* class))))
+ (nraw "parameter `~S' is not a location-reference class! (ignored)~%" class))
+;; line 904 "markup.nw"
+ (t `(markup::define-environment-methods
+ DO-MARKUP-LOCREF-LAYER
+ (,(if class
+ `(locrefcls (EQL ',(cdr (lookup-locref-class
+ *indexstyle* class))))
+ '(locrefcls layered-location-class))
+ ,(if depth `(depth (EQL ,depth)) '(depth number))
+ ,(if layer `(layer (EQL ,layer)) '(layer number)))
+ :declare ((declare (ignore depth layer)))
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))))))
+;; line 930 "markup.nw"
+(defmacro markup-locref (&key open close class attr depth)
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 932 "markup.nw"
+
+;; line 294 "markup.nw"
+((and attr (progn (setq attr (stringify attr))
+ (not (lookup-catattr *indexstyle* attr))))
+ (nraw "parameter `~S' is not an attribute! (ignored)~%" attr))
+;; line 933 "markup.nw"
+
+;; line 265 "markup.nw"
+((and depth (not (integerp depth)))
+ (nraw "parameter `~S' is not a number! (ignored)~%" depth))
+;; line 934 "markup.nw"
+
+;; line 282 "markup.nw"
+((and class (progn (setq class (stringify class))
+ (not (lookup-locref-class *indexstyle* class))))
+ (nraw "parameter `~S' is not a location-reference class! (ignored)~%" class))
+;; line 935 "markup.nw"
+ (t `(markup::define-environment-methods
+ DO-MARKUP-LOCREF
+ (,(if attr
+ `(attr (EQL ',(lookup-catattr *indexstyle* attr)))
+ '(attr category-attribute))
+ ,(if class
+ `(locrefcls (EQL ',(cdr (lookup-locref-class
+ *indexstyle* class))))
+ '(locrefcls layered-location-class))
+ ,(if depth `(depth (EQL ,depth)) '(depth number)))
+ :declare ((declare (ignore attr locrefcls depth)))
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))))))
+;; line 1002 "markup.nw"
+(defmacro markup-range (&whole whole &rest args)
+ (destructuring-switch-bind (&key
+ open close sep class length
+ &switch ignore-end)
+ args
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 260 "markup.nw"
+((and sep (not (stringp sep)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" sep))
+;; line 1008 "markup.nw"
+
+;; line 282 "markup.nw"
+((and class (progn (setq class (stringify class))
+ (not (lookup-locref-class *indexstyle* class))))
+ (nraw "parameter `~S' is not a location-reference class! (ignored)~%" class))
+;; line 1009 "markup.nw"
+ ((and length (not (numberp length)))
+ (nraw "parameter `~S' is not a number! (ignored)~%" length))
+ (t `(let ()
+ (markup::define-list-environment-methods
+ DO-MARKUP-RANGE
+ (,(if class
+ `(locrefcls (EQL ',(cdr (lookup-locref-class
+ *indexstyle* class))))
+ '(locrefcls layered-location-class))
+ ,(if length
+ `(length (EQL ,length))
+ '(length number)))
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))
+ :sep ,(when sep `((do-markup-string ,sep))))
+ (define-method markup::MARKUP-RANGE-PRINT-END-P
+ (,(if class
+ `(locrefcls (EQL ',(cdr (lookup-locref-class
+ *indexstyle* class))))
+ '(locrefcls layered-location-class))
+ ,(if length
+ `(length (EQL ,length))
+ '(length number)))
+ :declare ((declare (ignore locrefcls length)))
+ :body (,(not ignore-end))))))))
+;; line 1064 "markup.nw"
+(defmacro markup-crossref-list (&key open sep close class)
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 260 "markup.nw"
+((and sep (not (stringp sep)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" sep))
+;; line 1066 "markup.nw"
+
+;; line 288 "markup.nw"
+((and class (progn (setq class (stringify class))
+ (not (lookup-crossref-class *indexstyle* class))))
+ (nraw "parameter `~S' is not a cross-reference class! (ignored)~%" class))
+;; line 1067 "markup.nw"
+ (t `(markup::define-list-environment-methods
+ DO-MARKUP-CROSSREF-LIST
+ (,(if class
+ `(xrefcls (EQL ',(cdr (lookup-crossref-class *indexstyle*
+ class))))
+ '(xrefcls crossref-location-class)))
+ :declare ((declare (ignore xrefcls)))
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))
+ :sep ,(when sep `((do-markup-string ,sep)))))))
+;; line 1103 "markup.nw"
+(defmacro markup-crossref-layer-list (&key open sep close class)
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 260 "markup.nw"
+((and sep (not (stringp sep)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" sep))
+;; line 1105 "markup.nw"
+
+;; line 288 "markup.nw"
+((and class (progn (setq class (stringify class))
+ (not (lookup-crossref-class *indexstyle* class))))
+ (nraw "parameter `~S' is not a cross-reference class! (ignored)~%" class))
+;; line 1106 "markup.nw"
+ (t `(markup::define-list-environment-methods
+ DO-MARKUP-CROSSREF-LAYER-LIST
+ (,(if class
+ `(xrefcls (EQL ',(cdr (lookup-crossref-class *indexstyle*
+ class))))
+ '(xrefcls crossref-location-class)))
+ :declare ((declare (ignore xrefcls)))
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))
+ :sep ,(when sep `((do-markup-string ,sep)))))))
+;; line 1134 "markup.nw"
+(defmacro markup-crossref-layer (&key open close class)
+ (cond
+;; line 245 "markup.nw"
+((and open (not (stringp open)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" open))
+((and close (not (stringp close)))
+ (nraw "parameter `~S' is not a string! (ignored)~%" close))
+;; line 1136 "markup.nw"
+
+;; line 288 "markup.nw"
+((and class (progn (setq class (stringify class))
+ (not (lookup-crossref-class *indexstyle* class))))
+ (nraw "parameter `~S' is not a cross-reference class! (ignored)~%" class))
+;; line 1137 "markup.nw"
+ (t `(markup::define-list-environment-methods
+ DO-MARKUP-CROSSREF-LAYER
+ (,(if class
+ `(xrefcls (EQL ',(cdr (lookup-crossref-class *indexstyle*
+ class))))
+ '(xrefcls crossref-location-class)))
+ :declare ((declare (ignore xrefcls)))
+ :open ,(when open `((do-markup-string ,open)))
+ :close ,(when close `((do-markup-string ,close)))))))
+;; line 1188 "markup.nw"
+(eval-when (compile load eval)
+ (defparameter *markup-user-interface-definitions*
+ '(*markup-verbose-mode*
+ *markup-verbose-open*
+ *markup-verbose-close*
+ markup-crossref-layer
+ markup-crossref-layer-list
+ markup-crossref-list
+ markup-index
+ markup-letter-group
+ markup-letter-group-list
+ markup-indexentry
+ markup-indexentry-list
+ markup-keyword
+ markup-keyword-list
+ markup-locclass-list
+ markup-locref-class
+ markup-attribute-group-list
+ markup-attribute-group
+ markup-locref-list
+ markup-locref
+ markup-locref-layer-list
+ markup-locref-layer
+ markup-range
+ markup-trace
+ )))
+
+;; line 1238 "markup.nw"
+(eval-when (compile load eval)
+
+;; line 89 "markup.nw"
+(export '(*markup-output-stream*
+ *markup-verbose-mode*
+ *markup-verbose-open*
+ *markup-verbose-close*
+ *indexstyle-readtable*))
+;; line 347 "markup.nw"
+(export '(do-markup-index))
+;; line 1217 "markup.nw"
+(export '*markup-user-interface-definitions*)
+(export *markup-user-interface-definitions*)
+;; line 1240 "markup.nw"
+ )
+
+;; line 1178 "markup.nw"
+(defvar *RCS-Identifier* '(
+;; line 1244 "markup.nw"
+("markup" . "$Id: markup.nw,v 1.24 1997/03/26 16:18:58 kehr Exp $")
+;; line 236 "startup.nw"
+("startup" . "$Id: startup.nw,v 1.17 1997/03/26 16:19:03 kehr Exp $")
+;; line 1178 "markup.nw"
+ ))
+
+;; this should be the last of the module since it defines the
+;; additional package `xindy'.
+;; line 210 "startup.nw"
+;; $Id: startup.nw,v 1.17 1997/03/26 16:19:03 kehr Exp $
+
+(lisp:defpackage "XINDY")
+(lisp:in-package "XINDY")
+
+(eval-when (compile load eval)
+ (lisp:use-package "BASE")
+ (lisp:use-package :xindy-version)
+ (lisp:use-package "MARKUP")
+ (lisp:use-package "CLOS")
+ (lisp:use-package "COMMON-LISP")
+ #+CLISP (lisp:use-package "EXT")
+ (lisp:import markup:*markup-user-interface-definitions*))
+
+(eval-when (compile load eval)
+ (pushnew :HANDLER *features*))
+;; FIXME: error messages about package locks
+;(eval-when (compile load eval)
+; (pushnew :BREAK-DRIVER *features*))
+
+;; line 44 "startup.nw"
+(defun issue-startup-message ()
+ (info "xindy kernel version: ~A~%" *xindy-kernel-version*)
+ (info "~A version ~A~% architecture: ~A~%"
+ (lisp-implementation-type) (lisp-implementation-version)
+ (machine-version))
+ )
+
+(defun startup (&key idxstyle rawindex output logfile
+ show-version markup-trace (trace-level 0))
+ (when show-version
+ (issue-startup-message)
+ (exit-normally))
+ (when markup-trace (setq *markup-verbose-mode* t))
+ #+:HANDLER
+ (handler-case
+ (do-startup idxstyle rawindex output logfile trace-level)
+ (error
+ (condition)
+ (oops* (simple-condition-format-string condition)
+ (simple-condition-format-arguments condition))
+ (error-exit)))
+ #-:HANDLER
+ (do-startup idxstyle rawindex output logfile trace-level))
+;; line 70 "startup.nw"
+(defun do-startup (idxstyle raw-index output logfile trace-level)
+ (set-searchpath-by-environment)
+ (setq custom:*default-file-encoding* charset:iso-8859-1)
+ (when logfile
+ (info "~&Opening logfile ~S " logfile)
+ (handler-case
+ (setq *logging-stream* (open logfile
+ :direction :output
+ :if-does-not-exist :create
+ :if-exists :supersede))
+ (error ()
+ (oops "Opening logfile ~S failed!" logfile)
+ (error-exit)))
+ (info "(done)~%")
+ ;; Set necessary flags...
+ (setq *logging-on* t)
+ (case trace-level
+ (0)
+ (1 (setq *mappings-trace* t))
+ (2 (setq *mappings-trace* t) (setq *locref-trace* t))
+ (3 (setq *mappings-trace* t) (setq *locref-trace* t))
+ (t (error "Invalid :trace-level ~S !" trace-level)))
+ #+:ORDRULES (when *mappings-trace*
+ (setq ordrules::*message-logging* 1))
+
+ (multiple-value-bind (sec min hour day mon year)
+ (get-decoded-time)
+ (gol t ";; This logfile was generated automatically by `xindy'~%")
+ (gol t ";; at ~2,'0D.~2,'0D.~4,'0D ~2,'0D:~2,'0D:~2,'0D~%"
+ day mon year hour min sec))
+ (gol t ";; Indexstyle: ~S, Rawindex: ~S, Output: ~S~%~%"
+ idxstyle raw-index output)
+ )
+
+ (info "~&Reading indexstyle...~%")
+ (let ((*readtable* idxstyle:*indexstyle-readtable*))
+ (idxstyle:do-require idxstyle))
+ (info "~&Finished reading indexstyle.")
+ (info "~&Finalizing indexstyle... ")
+ (idxstyle:make-ready idxstyle:*indexstyle*)
+ (info "(done)~%~%")
+
+ (info "~&Reading raw-index ~S..." raw-index)
+ (load raw-index :verbose nil)
+ (info "~&Finished reading raw-index.~%~%")
+
+ (handler-case
+ (setq *markup-output-stream*
+ (open output
+ :direction :output
+ :if-does-not-exist :create
+ :if-exists :supersede))
+ (error ()
+ (oops "Opening file ~S failed!" output)
+ (error-exit)))
+
+ (info "~&Processing index...")
+ (index:process-index index:*index*)
+ (info "~&Finished processing index.~%~%")
+
+ (info "~&Writing markup...")
+ (markup:do-markup-index index:*index*)
+ (info "~%Markup written into file ~S.~%" output))
+;; line 139 "startup.nw"
+(defun set-searchpath-by-environment ()
+ (let ((sp (#+CLISP
+ system::getenv
+ #+ALLEGRO
+ sys:getenv
+ "XINDY_SEARCHPATH")))
+ (when sp (idxstyle:set-searchpath-by-string sp))))
+;; line 170 "startup.nw"
+#+:BREAK-DRIVER
+(fmakunbound '*break-driver*)
+
+#+:BREAK-DRIVER
+(defun *break-driver* (continuable
+ &optional (condition nil) (print-it nil)
+ &aux (may-continue
+ (or continuable
+ (and condition
+ (find-restart 'continue condition))
+ ) )
+ (interactive-p (interactive-stream-p *debug-io*))
+ (commandsr '())
+ )
+ (declare (ignore may-continue interactive-p commandsr))
+ ;; This when-clause is from Bruno Haible.
+ (when (and condition print-it)
+ (terpri *error-output*)
+ (write-string "*** - " *error-output*)
+ #+CLISP (system::print-condition condition *error-output*)
+ #-CLISP (print condition *error-output*)
+ )
+ (format *ERROR-OUTPUT* "~&Bye.")
+ (error-exit))
+
+#+:BREAK-DRIVER-OLD
+(defun *break-driver* (continuable &rest rest)
+ (declare (ignore continuable rest))
+ (format *ERROR-OUTPUT* "~&Bye.")
+ (error-exit))
+
+#+:BREAK-DRIVER
+(eval-when (compile load eval)
+ (export '*break-driver*))
+
+;; line 230 "startup.nw"
+(eval-when (compile load eval)
+
+;; line 135 "startup.nw"
+(export '(startup *xindy-kernel-version*))
+;; line 232 "startup.nw"
+ )
diff --git a/Build/source/utils/xindy/xindy-2.4/src/ordrules.lsp b/Build/source/utils/xindy/xindy-2.4/src/ordrules.lsp
new file mode 100644
index 00000000000..ea372eb94ea
--- /dev/null
+++ b/Build/source/utils/xindy/xindy-2.4/src/ordrules.lsp
@@ -0,0 +1,419 @@
+;;; $Id$
+;;;----------------------------------------------------------------------
+
+;;;
+;;; ordrules --- order rules for xindy
+;;;
+;;; (history at end)
+
+
+(provide "ordrules")
+
+
+;;;; ============================================================
+;;;;
+;;;; SPECIFICATION
+;;;;
+
+;;;
+;;; package ordrules XXX
+;;;
+
+(defpackage "ORDRULES"
+ (:documentation "Order rules for xindy.
+Provides functionality for merge-rules and sort-rules, as ordrule collections.
+An ordrule collection is an ordered set of order rules.
+An order rule is an object that manages replacement of a string or
+regular expression by a string.
+Ordrule collections are applied to strings, the result is created by
+successive application of matching order rules.")
+ (:use common-lisp clos regexp)
+ (:shadow match)
+ (:export ;; object interface
+ "MAKE-ORDRULE-TABLE" "ADD-RULE" "APPLY-RULES"
+ ;; legacy (C plugin) interface
+ "INITIALIZE" "ADD-KEYWORD-MERGE-RULE" "ADD-KEYWORD-SORT-RULE"
+ "GEN-KEYWORD-MERGEKEY" "GEN-KEYWORD-SORTKEY"
+ "*MESSAGE-BUFFER-PTR*" "*MESSAGE-BUFFER*" "*MESSAGE-LOGGING*")
+ )
+(in-package "ORDRULES")
+
+
+
+;;;; ============================================================
+;;;;
+;;;; ORDRULE OBJECTS
+;;;;
+
+;;; class ORDRULE
+;;; Slots:
+;;; -- match: regexp, string, or char that might be matched
+;;; -- repl: replacement for the matched substring
+;;; -- again: boolean flag if repl should be eligible for further ordrules
+;;;
+;;; subclass ORDRULE-STRING -- no additional slots
+;;; subclass ORDRULE-CHAR -- no additional slots
+;;; subclass ORDRULE-REGEXP
+;;; Additional Slots:
+;;; -- only-at-start: boolean flag if match should only be tested at start
+;;; of string
+
+(defclass ordrule ()
+ ((match :initarg :match :reader match)
+ (repl :initarg :repl :reader repl)
+ (again :initarg :again :reader again))
+ (:documentation
+ "An order rule that represents the replacement of a matching expression
+with a replacement string."))
+
+(defclass ordrule-string (ordrule)
+ ()
+ (:documentation
+ "An ordrule where the matching expression is a string"))
+
+(defclass ordrule-char (ordrule)
+ ()
+ (:documentation
+ "An ordrule where the matching expression is a char"))
+
+(defclass ordrule-regexp (ordrule)
+ ((pattern :initarg :pattern :reader pattern)
+ (only-at-start :initarg :only-at-start :reader only-at-start))
+ (:documentation
+ "An ordrule where the matching expression is a regexp"))
+
+(defmethod print-object ((obj ordrule) stream)
+ "Print an ordrule."
+ (format stream "#<ordrule: '~A' => '~A' :again ~A>"
+ (match obj) (repl obj) (again obj)))
+
+(defmethod print-object ((obj ordrule-regexp) stream)
+ "Print an ordrule."
+ (format stream "#<ordrule-regexp: '~A' => '~A' :again ~A :only-at-start ~A>"
+ (pattern obj) (repl obj) (again obj) (only-at-start obj)))
+
+(defun make-ordrule-string (match repl &key again)
+ "Create an ordrule-string object.
+MATCH is a string to compare."
+ (make-instance 'ordrule-string :match match :repl repl :again again))
+
+(defun make-ordrule-char (match repl &key again)
+ "Create an ordrule-string object.
+MATCH is a character to compare."
+ (make-instance 'ordrule-char :match match :repl (string repl) :again again))
+
+(defun make-ordrule-regexp (match-pattern repl &key again (extended t))
+ "Create an ordrule-regexp object.
+MATCH-PATTERN is a POSIX regular expression.
+The boolean keyword argument :extended tells if the regex is a basic
+one or an extended one; default is to use extended ones."
+ (let* ((only-at-start (char= (char match-pattern 0) #\^))
+ (match (if only-at-start (subseq match-pattern 1) match-pattern)))
+ (make-instance 'ordrule-regexp
+ :match (regexp-compile (concatenate 'string "^(" match ")")
+ :extended extended)
+ :repl repl :again again
+ :pattern match-pattern :only-at-start only-at-start)))
+
+;; A regexp-compile object does not survive dump and reload.
+;; Therefore we have to initialize it at first usage.
+(defvar *REGEXP-PATTERN*
+ nil
+ "If this pattern matches, the string is a regexp.")
+
+(defun make-ordrule (match repl &key again)
+ "Create an ordrule object.
+MATCH may be a string, a char, or a POSIX regular expression.
+If it's a regexp, it's an extended one."
+ (or *REGEXP-PATTERN*
+ (setq *REGEXP-PATTERN* (regexp-compile "[][|(){}.*+^$?]")))
+ (cond ((characterp match)
+ (make-ordrule-char match repl :again again))
+ ((= (length match) 1)
+ (make-ordrule-char (char match 0) repl :again again))
+ ((regexp-exec *REGEXP-PATTERN* match)
+ (make-ordrule-regexp match repl :again again))
+ (t (make-ordrule-string match repl :again again))))
+
+
+;;;
+;;; (try-rule RULE SOURCE) => FINAL ; SOURCE-REST or <no values>
+;;;
+
+(defgeneric try-rule (ordrule source &key at-start)
+ (:documentation "Apply an ordrule to a source string.
+If the rule does not match, return nothing. If it matches, return two
+values: the 1st is the final prefix with the replacement
+string and the 2nd is the rest of SOURCE that's left after the matched
+text. If the rule's again flag is true, FINAL will be the empty string
+and the replacement will be at the start of SOURCE-REST.
+An ordrule is not allowed to turn a source completely into an empty string.
+If that would happen, a warning is output and nothing is returned.
+That situation would exist, if AT-START is true and both FINAL and
+SOURCE-REST would be empty.
+AT-START tells if we are at the start to process the source string."))
+
+(defmethod try-rule ((rule ordrule-char) source &key at-start)
+ (if (char= (char source 0) (match rule))
+ (maybe-again-maybe-no rule source at-start
+ (repl rule) (subseq source 1))
+ (values)))
+
+(defun maybe-again-maybe-no (rule source at-start repl source-rest)
+ (cond ((and at-start (string= repl "") (string= source-rest ""))
+ (warn "Would replace complete index key by empty string, ignoring ~S" rule)
+ (values source ""))
+ ((again rule)
+ (values "" (concatenate 'string repl source-rest)))
+ (t (values repl source-rest))))
+
+(defmethod try-rule ((rule ordrule-string) source &key at-start)
+ (let* ((match-string (match rule))
+ (match-length (length match-string)))
+ (cond ((> match-length (length source)) (values))
+ ((string= source match-string :end1 match-length)
+ (maybe-again-maybe-no rule source at-start
+ (repl rule) (subseq source match-length)))
+ (t (values)))))
+
+(defmethod try-rule ((rule ordrule-regexp) source &key at-start)
+ (if (and (only-at-start rule) (not at-start))
+ nil
+ (let ((match-regexp (multiple-value-list (regexp-exec (match rule) source))))
+ (if match-regexp
+ (maybe-again-maybe-no rule source at-start
+ (maybe-repl-subexpr (repl rule) (rest match-regexp) source)
+ (subseq source (match-end (first match-regexp))))
+ (values)))))
+
+;; A regexp-compile object does not survive dump and reload.
+;; Therefore we have to initialize it at first usage.
+(defvar *REPL-PATTERN*
+ nil
+ "Compiled regexp that matches a backpattern in a regexp replacement text.")
+
+;; We need to substitute all \x and & constructs in the replacement text by
+;; the respective subexpression from source's matches. They are
+;; located with a regexp in a loop and we collect in 'final-repl the
+;; strings in front of each \x and the actual subexpression.
+(defun maybe-repl-subexpr (repl source-matches source)
+ (or *REPL-PATTERN*
+ (setq *REPL-PATTERN* (regexp-compile "\\\\([1-9])|&" :extended t)))
+ (do* ((start 0 (match-end (first subexpr-match)))
+ (subexpr-match (multiple-value-list (regexp-exec *REPL-PATTERN* repl))
+ (multiple-value-list (regexp-exec *REPL-PATTERN* repl
+ :start start)))
+ (final-repl ""))
+ ((null subexpr-match)
+ ;; Don't forget to return the rest of the string, too. Its
+ ;; index is now in 'start.
+ (concatenate 'string final-repl (subseq repl start)))
+ ;; OK, need a subexpr replacement. First, we determine which subexpression
+ ;; this shall be: If it's "&", the second match subexpression will be nil,
+ ;; as the parenthesis did not match anything. Otherwise the 2nd match
+ ;; subexpr will be the digit. Then we get that subexpression from the
+ ;; source string. Finally, we add the 'repl string part in front of \x and
+ ;; the respective subexpression to 'final-repl and are ready to look for
+ ;; our next \x construct.
+ (let* ((subexpr-match-struct (second subexpr-match))
+ (subexpr (and subexpr-match-struct
+ (match-string repl subexpr-match-struct)))
+ (subexpr-repl (match-string source
+ (nth (if (null subexpr)
+ 0
+ (read-from-string subexpr))
+ source-matches))))
+ (setq final-repl
+ (concatenate 'string final-repl
+ (subseq repl 0 (match-start (first subexpr-match)))
+ subexpr-repl)))))
+
+
+;;;
+;;; (rule-first-char RULE) => char or :regexp
+;;;
+
+(defgeneric rule-first-char (rule)
+ (:documentation "Returns the first char of a rule match.
+This returns either the first char of a rule match, or :regexp
+if that first char is a regular expression. The is used to find the
+slot for a rule in a rule table."))
+
+(defmethod rule-first-char ((rule ordrule-char))
+ (match rule))
+
+(defmethod rule-first-char ((rule ordrule-string))
+ (char (match rule) 0))
+
+(defmethod rule-first-char ((rule ordrule-regexp))
+ (let* ((pattern (pattern rule))
+ (start-index (if (only-at-start rule) 1 0))
+ (first-char (char pattern start-index)))
+ (cond ((char= first-char #\\)
+ (char pattern (1+ start-index)))
+ ((find first-char "[]|(){}.*+?")
+ :regexp)
+ (t first-char))))
+
+
+
+;;;; ============================================================
+;;;;
+;;;; ORDRULE TABLES
+;;;;
+
+;; An ordrule table is a hash table of ordrule lists, indexed by the first
+;; character of the rule. The key :regexp is the entry for rules that start
+;; with a regexp pattern.
+
+(defclass ordrule-table ()
+ ((table :initarg :table :reader table))
+ (:documentation
+ "A collection of ordrules."))
+
+(defmethod print-object ((obj ordrule-table) stream)
+ "Print an ordrule table."
+ (format stream "#<ordrule table with ~A entries>" (hash-table-count (table obj))))
+
+(defun make-ordrule-table ()
+ "Create an ordrule-table object."
+ (make-instance 'ordrule-table :table (make-hash-table :size 256)))
+
+(defun add-rule (rule-table rule)
+ "Add a rule to an ordrule table."
+ (let* ((first-char (rule-first-char rule))
+ (first-char-rules (gethash first-char (table rule-table))))
+ (if first-char-rules
+ (nconc first-char-rules (list rule))
+ (setf (gethash first-char (table rule-table)) (list rule)))))
+
+;; XXX This is the place where we might want to sort rules according to their
+;; length. But then we should also cache that sort result, because this
+;; function is called for each character in the index!
+;;
+;; XXX Maybe we should try a cache anyhow, to save appends, too? Need to
+;; measure that.
+(defun get-rules (rule-table source-start)
+ (append (gethash source-start (table rule-table))
+ (gethash :regexp (table rule-table))))
+
+(defun apply-rules-once (rule-table source at-start)
+ "Apply rules from rule-table once to source.
+Returns two values: (1) prefix that has been processed, (2) suffix that has
+still to be processed."
+ (dolist (rule (get-rules rule-table (char source 0))
+ (values))
+ (multiple-value-bind (prefix suffix)
+ (try-rule rule source :at-start at-start)
+ (if (stringp prefix)
+ (return (values prefix suffix))))))
+
+(defun apply-rules (rule-table source &optional (at-start t))
+ "Apply rules from rule-table to source."
+ (multiple-value-bind (prefix suffix)
+ (apply-rules-once rule-table source at-start)
+ (log-rule (format nil "apply rules once: '~A' => '~A' '~A'~%"
+ source prefix suffix))
+ (cond ((null prefix)
+ (if (= (length source) 1)
+ source
+ (concatenate 'string (subseq source 0 1)
+ (apply-rules rule-table (subseq source 1) nil))))
+ ((string= suffix "") prefix)
+ (t (concatenate 'string prefix
+ (apply-rules rule-table suffix nil))))))
+
+
+
+;;;; ============================================================
+;;;;
+;;;; LEGACY (C PLUGIN) INTERFACE
+;;;;
+
+;; The following code realizes the interface of xindy 2.3, even though we
+;; could now use real Lisp objects. This is a transient phase only.
+
+(defvar *merge-rule-table*
+ (make-ordrule-table))
+
+;; By default, we have runs 0..7.
+(defvar *sort-rule-tables*
+ (let ((tables (make-array '(8) :element-type 'ordrule-table)))
+ (dotimes (i 8)
+ (setf (aref tables i) (make-ordrule-table)))
+ tables))
+
+(defun initialize (num)
+ (setq *sort-rule-tables* (make-array (list num) :element-type 'ordrule-table))
+ (dotimes (i num)
+ (setf (aref *sort-rule-tables* i) (make-ordrule-table))))
+
+(defun add-keyword-rule (rule-table rule repl again ruletype)
+ (let* ((again (if (= again 1) t nil))
+ (rule-obj (ecase ruletype
+ (0 (make-ordrule rule repl :again again))
+ (1 (make-ordrule-string rule repl :again again))
+ (2 (make-ordrule-regexp rule repl :again again :extended nil))
+ (3 (make-ordrule-regexp rule repl :again again))
+ (4 (make-ordrule-char rule repl :again again)))))
+ (add-rule rule-table rule-obj)))
+
+(defun add-keyword-merge-rule (rule repl again ruletype)
+ (let* ((rule-list (add-keyword-rule *merge-rule-table* rule
+ repl again ruletype))
+ (message (format nil "Add merge rule: ~S~%" (first (last rule-list)))))
+ (log-rule message)))
+
+(defun add-keyword-sort-rule (run rule repl again ruletype)
+ (let* ((rule-list (add-keyword-rule (aref *sort-rule-tables* run)
+ rule repl again ruletype))
+ (message (format nil "Add sort rule to run ~A: ~S~%"
+ run (first (last rule-list)))))
+ (log-rule message)))
+
+(defun gen-keyword-mergekey (key)
+ (let ((result (apply-rules *merge-rule-table* key)))
+ (log-rule (format nil "Final merge-rule result: '~A' -> '~A'~%"
+ key result))
+ result))
+
+(defun gen-keyword-sortkey (key run)
+ (let ((result (apply-rules (aref *sort-rule-tables* run) key)))
+ (log-rule (format nil "Final sort-rule result, run ~A: '~A' -> '~A'~%"
+ run key result))
+ result))
+
+
+;;;
+;;; Logging
+;;;
+
+(defvar *message-logging*
+ nil
+ "Boolean: Shall rule replacement be logged?")
+
+(defvar *message-buffer*
+ ""
+ "String with the log message.
+This is remaining cruft from the C plugin that could not use Lisp
+output streams itself.")
+
+(defvar *message-buffer-ptr*
+ 0
+ "Current position in *message-buffer*.
+This is remaining cruft from the C plugin that could not use Lisp
+output streams itself.")
+
+(defun log-rule (message)
+ (and *message-logging*
+ (if (= (incf *message-buffer-ptr*) 1)
+ (setq *message-buffer* message)
+ (setq *message-buffer* (concatenate 'string *message-buffer*
+ message)))
+ ))
+
+
+
+;;;======================================================================
+;;
+;; $Log$
diff --git a/Build/source/utils/xindy/xindy-2.4/src/version.lsp b/Build/source/utils/xindy/xindy-2.4/src/version.lsp
new file mode 100644
index 00000000000..e7b219bba94
--- /dev/null
+++ b/Build/source/utils/xindy/xindy-2.4/src/version.lsp
@@ -0,0 +1,13 @@
+;; $Id$ -*- Lisp -*-
+;; ------------------------------------------------------------
+;; version identification of xindy kernel
+;; src/version.lsp.
+
+(lisp:provide "version")
+
+(defpackage :xindy-version
+ (:export *xindy-kernel-version*))
+
+(in-package :xindy-version)
+
+(defconstant *xindy-kernel-version* "3.0")