summaryrefslogtreecommitdiff
path: root/Build/source/utils/xindy-new/xindy/src
diff options
context:
space:
mode:
authorPeter Breitenlohner <peb@mppmu.mpg.de>2010-05-11 13:45:07 +0000
committerPeter Breitenlohner <peb@mppmu.mpg.de>2010-05-11 13:45:07 +0000
commitc73f77e8603276a0e37a2cbe350e8d146cad9cfd (patch)
tree6265344f2cdf0becd78cf67750f44ec807abe807 /Build/source/utils/xindy-new/xindy/src
parentbc7e6ba64528ec9408b8440f62e1e6de4bbabb35 (diff)
xindy 2.4, also rename xindy-new => xindy
git-svn-id: svn://tug.org/texlive/trunk@18199 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Build/source/utils/xindy-new/xindy/src')
-rw-r--r--Build/source/utils/xindy-new/xindy/src/Makefile.am71
-rw-r--r--Build/source/utils/xindy-new/xindy/src/Makefile.in430
-rw-r--r--Build/source/utils/xindy-new/xindy/src/base.lsp237
-rw-r--r--Build/source/utils/xindy-new/xindy/src/defaults.xdy.in5
-rw-r--r--Build/source/utils/xindy-new/xindy/src/dump-xindy.lsp33
-rw-r--r--Build/source/utils/xindy-new/xindy/src/idxstyle.lsp2126
-rw-r--r--Build/source/utils/xindy-new/xindy/src/index.lsp1333
-rw-r--r--Build/source/utils/xindy-new/xindy/src/locref.lsp556
-rw-r--r--Build/source/utils/xindy-new/xindy/src/markup.lsp1289
-rw-r--r--Build/source/utils/xindy-new/xindy/src/ordrules.lsp408
-rw-r--r--Build/source/utils/xindy-new/xindy/src/version.lsp13
11 files changed, 0 insertions, 6501 deletions
diff --git a/Build/source/utils/xindy-new/xindy/src/Makefile.am b/Build/source/utils/xindy-new/xindy/src/Makefile.am
deleted file mode 100644
index d7aac1f3854..00000000000
--- a/Build/source/utils/xindy-new/xindy/src/Makefile.am
+++ /dev/null
@@ -1,71 +0,0 @@
-## 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-new/xindy/src/Makefile.in b/Build/source/utils/xindy-new/xindy/src/Makefile.in
deleted file mode 100644
index 8cd29769801..00000000000
--- a/Build/source/utils/xindy-new/xindy/src/Makefile.in
+++ /dev/null
@@ -1,430 +0,0 @@
-# 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-new/xindy/src/base.lsp b/Build/source/utils/xindy-new/xindy/src/base.lsp
deleted file mode 100644
index 4158d212f7b..00000000000
--- a/Build/source/utils/xindy-new/xindy/src/base.lsp
+++ /dev/null
@@ -1,237 +0,0 @@
-;; 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-new/xindy/src/defaults.xdy.in b/Build/source/utils/xindy-new/xindy/src/defaults.xdy.in
deleted file mode 100644
index bd149fdbae0..00000000000
--- a/Build/source/utils/xindy-new/xindy/src/defaults.xdy.in
+++ /dev/null
@@ -1,5 +0,0 @@
-;; defaults.xdy.in 29 Mar 09 -*- Lisp -*-
-;;------------------------------------------------------------
-
-(setq *load-paths* (list (pathname ".")
- (pathname "@MODULEDIR@")))
diff --git a/Build/source/utils/xindy-new/xindy/src/dump-xindy.lsp b/Build/source/utils/xindy-new/xindy/src/dump-xindy.lsp
deleted file mode 100644
index 73dc63677bd..00000000000
--- a/Build/source/utils/xindy-new/xindy/src/dump-xindy.lsp
+++ /dev/null
@@ -1,33 +0,0 @@
-;; $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-new/xindy/src/idxstyle.lsp b/Build/source/utils/xindy-new/xindy/src/idxstyle.lsp
deleted file mode 100644
index 734d3997e22..00000000000
--- a/Build/source/utils/xindy-new/xindy/src/idxstyle.lsp
+++ /dev/null
@@ -1,2126 +0,0 @@
-;; 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 #\;
- 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-new/xindy/src/index.lsp b/Build/source/utils/xindy-new/xindy/src/index.lsp
deleted file mode 100644
index 7d171f96fab..00000000000
--- a/Build/source/utils/xindy-new/xindy/src/index.lsp
+++ /dev/null
@@ -1,1333 +0,0 @@
-;; 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-new/xindy/src/locref.lsp b/Build/source/utils/xindy-new/xindy/src/locref.lsp
deleted file mode 100644
index 428b629e910..00000000000
--- a/Build/source/utils/xindy-new/xindy/src/locref.lsp
+++ /dev/null
@@ -1,556 +0,0 @@
-;; 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-new/xindy/src/markup.lsp b/Build/source/utils/xindy-new/xindy/src/markup.lsp
deleted file mode 100644
index c0f696e2a6e..00000000000
--- a/Build/source/utils/xindy-new/xindy/src/markup.lsp
+++ /dev/null
@@ -1,1289 +0,0 @@
-;; 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-new/xindy/src/ordrules.lsp b/Build/source/utils/xindy-new/xindy/src/ordrules.lsp
deleted file mode 100644
index 60fa2fa678f..00000000000
--- a/Build/source/utils/xindy-new/xindy/src/ordrules.lsp
+++ /dev/null
@@ -1,408 +0,0 @@
-;;; $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.
-AT-START tells if we are at the start to process the source string."))
-
-(defmethod try-rule ((rule ordrule-char) source &key at-start)
- (declare (ignore at-start))
- (if (char= (char source 0) (match rule))
- (maybe-again rule (repl rule) (subseq source 1))
- (values)))
-
-(defun maybe-again (rule repl source-rest)
- (if (again rule)
- (values "" (concatenate 'string repl source-rest))
- (values repl source-rest)))
-
-(defmethod try-rule ((rule ordrule-string) source &key at-start)
- (declare (ignore 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 rule (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 rule
- (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 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. 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-string repl (second subexpr-match)))
- (subexpr-repl (match-string source
- (nth (if (string= 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-new/xindy/src/version.lsp b/Build/source/utils/xindy-new/xindy/src/version.lsp
deleted file mode 100644
index e7b219bba94..00000000000
--- a/Build/source/utils/xindy-new/xindy/src/version.lsp
+++ /dev/null
@@ -1,13 +0,0 @@
-;; $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")