diff options
author | Peter Breitenlohner <peb@mppmu.mpg.de> | 2011-03-13 13:16:44 +0000 |
---|---|---|
committer | Peter Breitenlohner <peb@mppmu.mpg.de> | 2011-03-13 13:16:44 +0000 |
commit | a002c295ae6054a4cfb9825ddb6e0d4f27ecde73 (patch) | |
tree | 1addafb42ef483a7ceb41abed3e9c877f808ee00 /Build/source/utils/xindy/xindy-2.4/src | |
parent | 908bf11dbd760fe92209f9c1fe90502a44fa90fc (diff) |
reorganize xindy-2.4 build system (part 1)
git-svn-id: svn://tug.org/texlive/trunk@21706 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Build/source/utils/xindy/xindy-2.4/src')
-rw-r--r-- | Build/source/utils/xindy/xindy-2.4/src/Makefile.am | 71 | ||||
-rw-r--r-- | Build/source/utils/xindy/xindy-2.4/src/Makefile.in | 430 | ||||
-rw-r--r-- | Build/source/utils/xindy/xindy-2.4/src/base.lsp | 237 | ||||
-rw-r--r-- | Build/source/utils/xindy/xindy-2.4/src/defaults.xdy.in | 5 | ||||
-rw-r--r-- | Build/source/utils/xindy/xindy-2.4/src/dump-xindy.lsp | 33 | ||||
-rw-r--r-- | Build/source/utils/xindy/xindy-2.4/src/idxstyle.lsp | 2127 | ||||
-rw-r--r-- | Build/source/utils/xindy/xindy-2.4/src/index.lsp | 1333 | ||||
-rw-r--r-- | Build/source/utils/xindy/xindy-2.4/src/locref.lsp | 556 | ||||
-rw-r--r-- | Build/source/utils/xindy/xindy-2.4/src/markup.lsp | 1289 | ||||
-rw-r--r-- | Build/source/utils/xindy/xindy-2.4/src/ordrules.lsp | 419 | ||||
-rw-r--r-- | Build/source/utils/xindy/xindy-2.4/src/version.lsp | 13 |
11 files changed, 6513 insertions, 0 deletions
diff --git a/Build/source/utils/xindy/xindy-2.4/src/Makefile.am b/Build/source/utils/xindy/xindy-2.4/src/Makefile.am new file mode 100644 index 00000000000..d7aac1f3854 --- /dev/null +++ b/Build/source/utils/xindy/xindy-2.4/src/Makefile.am @@ -0,0 +1,71 @@ +## Use `autoreconf' in top-level directory to recreate all +## autoconf/automake files. +## Or, call `automake Makefile' to create only Makefile.in. + +## Copyright (C) 2004-2005 by Gour. +## Copyright (C) 2008,2009 by Joachim Schrod. +## +## This program is free software; you can redistribute it and/or +## modify it under the terms of the GNU General Public License as +## published by the Free Software Foundation; either version 2 of the +## License, or (at your option) any later version. +## +## This program is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +## General Public License for more details. +## +## You should have received a copy of the GNU General Public License +## along with this program in the file COPYING; if not, write to the +## Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +## Boston, MA 02110-1301 USA. + +# Where the modules are found at runtime. +MODULEDIR = $(pkglibdir)/modules + + +# Automake has no CLISP support; moreover xindy.mem is not a binary +# to be stripped upon 'make install-strip'. We define it as DATA. +mem_DATA = xindy.mem + +# Tell the dist target about our sources, define the object files for +# our own rule and the .lib files for the clean definition. Don't use +# gmake-isms. +FASSRC = base.lsp ordrules.lsp locref.lsp idxstyle.lsp \ + index.lsp version.lsp markup.lsp +FAS = base.fas ordrules.fas locref.fas idxstyle.fas \ + index.fas version.fas markup.fas +FASLIBS = base.lib ordrules.lib locref.lib idxstyle.lib \ + index.lib version.lib markup.lib + +DEFAULTS = defaults.xdy +DUMP_XINDY = dump-xindy.lsp +MEMFILE = xindy.mem +CLISP = @CLISP@ -q -E iso-8859-1 + +xindy.mem: $(DEFAULTS) $(FAS) $(DUMP_XINDY) + rm -f $(MEMFILE) + $(CLISP) $(srcdir)/$(DUMP_XINDY) + if test "$(host_os)" != "mingw32"; then \ + gzip -9n $@; \ + mv $@.gz $@; \ + fi + +$(DEFAULTS): $(DEFAULTS).in Makefile + sed 's|@MODULEDIR[@]|$(MODULEDIR)|g' <$(srcdir)/$(DEFAULTS).in >$(DEFAULTS) + +EXTRA_DIST = $(DEFAULTS).in $(FASSRC) dump-xindy.lsp + +SUFFIXES = .fas .lsp +.lsp.fas: + $(CLISP) -c $< -o $@ + + +CLEANFILES = $(FAS) $(FASLIBS) $(DEFAULTS) xindy.mem + +# Dependencies required for parallel make. +markup.fas: index.fas version.fas +index.fas: idxstyle.fas ordrules.fas +idxstyle.fas: locref.fas +locref.fas: base.fas + diff --git a/Build/source/utils/xindy/xindy-2.4/src/Makefile.in b/Build/source/utils/xindy/xindy-2.4/src/Makefile.in new file mode 100644 index 00000000000..8cd29769801 --- /dev/null +++ b/Build/source/utils/xindy/xindy-2.4/src/Makefile.in @@ -0,0 +1,430 @@ +# Makefile.in generated by automake 1.11.1 from Makefile.am. +# @configure_input@ + +# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, +# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, +# Inc. +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. + +@SET_MAKE@ + +VPATH = @srcdir@ +pkgdatadir = $(datadir)/@PACKAGE@ +pkgincludedir = $(includedir)/@PACKAGE@ +pkglibexecdir = $(libexecdir)/@PACKAGE@ +am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd +install_sh_DATA = $(install_sh) -c -m 644 +install_sh_PROGRAM = $(install_sh) -c +install_sh_SCRIPT = $(install_sh) -c +INSTALL_HEADER = $(INSTALL_DATA) +transform = $(program_transform_name) +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : +build_triplet = @build@ +host_triplet = @host@ +subdir = xindy/src +DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.in +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +am__aclocal_m4_deps = $(top_srcdir)/../../m4/kpse-warnings.m4 \ + $(top_srcdir)/xindy/VERSION $(top_srcdir)/ac/xindy.ac \ + $(top_srcdir)/configure.ac +am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ + $(ACLOCAL_M4) +mkinstalldirs = $(install_sh) -d +CONFIG_CLEAN_FILES = +CONFIG_CLEAN_VPATH_FILES = +SOURCES = +DIST_SOURCES = +am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; +am__vpath_adj = case $$p in \ + $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ + *) f=$$p;; \ + esac; +am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; +am__install_max = 40 +am__nobase_strip_setup = \ + srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` +am__nobase_strip = \ + for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" +am__nobase_list = $(am__nobase_strip_setup); \ + for p in $$list; do echo "$$p $$p"; done | \ + sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ + $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ + if (++n[$$2] == $(am__install_max)) \ + { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ + END { for (dir in files) print dir, files[dir] }' +am__base_list = \ + sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ + sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' +am__installdirs = "$(DESTDIR)$(memdir)" +DATA = $(mem_DATA) +DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) +pkglibdir = @pkglibdir@ +ACLOCAL = @ACLOCAL@ +AMTAR = @AMTAR@ +AUTOCONF = @AUTOCONF@ +AUTOHEADER = @AUTOHEADER@ +AUTOMAKE = @AUTOMAKE@ +AWK = @AWK@ +CC = @CC@ +CCDEPMODE = @CCDEPMODE@ +CFLAGS = @CFLAGS@ +CLISP = @CLISP@ -q -E iso-8859-1 +CONVERT_FROM_UTF8 = @CONVERT_FROM_UTF8@ +CPPFLAGS = @CPPFLAGS@ +CYGPATH_W = @CYGPATH_W@ +DEFS = @DEFS@ +DEPDIR = @DEPDIR@ +ECHO_C = @ECHO_C@ +ECHO_N = @ECHO_N@ +ECHO_T = @ECHO_T@ +EXEEXT = @EXEEXT@ +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ +LATEX = @LATEX@ +LDFLAGS = @LDFLAGS@ +LEX = @LEX@ +LEXLIB = @LEXLIB@ +LEX_OUTPUT_ROOT = @LEX_OUTPUT_ROOT@ +LIBOBJS = @LIBOBJS@ +LIBS = @LIBS@ +LISP_RUN = @LISP_RUN@ +LN_S = @LN_S@ +LTLIBOBJS = @LTLIBOBJS@ +MAINT = @MAINT@ +MAKEINFO = @MAKEINFO@ +MKDIR_P = @MKDIR_P@ +OBJEXT = @OBJEXT@ +PACKAGE = @PACKAGE@ +PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ +PACKAGE_NAME = @PACKAGE_NAME@ +PACKAGE_STRING = @PACKAGE_STRING@ +PACKAGE_TARNAME = @PACKAGE_TARNAME@ +PACKAGE_URL = @PACKAGE_URL@ +PACKAGE_VERSION = @PACKAGE_VERSION@ +PATH_SEPARATOR = @PATH_SEPARATOR@ +PDFLATEX = @PDFLATEX@ +PERL = @PERL@ +SET_MAKE = @SET_MAKE@ +SHELL = @SHELL@ +STRIP = @STRIP@ +VERSION = @VERSION@ +WARNING_CFLAGS = @WARNING_CFLAGS@ +XINDY_RUN = @XINDY_RUN@ +abs_builddir = @abs_builddir@ +abs_srcdir = @abs_srcdir@ +abs_top_builddir = @abs_top_builddir@ +abs_top_srcdir = @abs_top_srcdir@ +ac_ct_CC = @ac_ct_CC@ +am__include = @am__include@ +am__leading_dot = @am__leading_dot@ +am__quote = @am__quote@ +am__tar = @am__tar@ +am__untar = @am__untar@ +bindir = @bindir@ +build = @build@ +build_alias = @build_alias@ +build_cpu = @build_cpu@ +build_os = @build_os@ +build_vendor = @build_vendor@ +builddir = @builddir@ +datadir = @datadir@ +datarootdir = @datarootdir@ +docdir = @docdir@ +dvidir = @dvidir@ +exec_prefix = @exec_prefix@ +host = @host@ +host_alias = @host_alias@ +host_cpu = @host_cpu@ +host_os = @host_os@ +host_vendor = @host_vendor@ +htmldir = @htmldir@ +includedir = @includedir@ +infodir = @infodir@ +install_sh = @install_sh@ +libdir = @libdir@ +libexecdir = @libexecdir@ +localedir = @localedir@ +localstatedir = @localstatedir@ +mandir = @mandir@ +memdir = @memdir@ +mkdir_p = @mkdir_p@ +oldincludedir = @oldincludedir@ +pdfdir = @pdfdir@ +prefix = @prefix@ +program_transform_name = @program_transform_name@ +psdir = @psdir@ +sbindir = @sbindir@ +sharedstatedir = @sharedstatedir@ +srcdir = @srcdir@ +sysconfdir = @sysconfdir@ +target_alias = @target_alias@ +top_build_prefix = @top_build_prefix@ +top_builddir = @top_builddir@ +top_srcdir = @top_srcdir@ + +# Where the modules are found at runtime. +MODULEDIR = $(pkglibdir)/modules + +# Automake has no CLISP support; moreover xindy.mem is not a binary +# to be stripped upon 'make install-strip'. We define it as DATA. +mem_DATA = xindy.mem + +# Tell the dist target about our sources, define the object files for +# our own rule and the .lib files for the clean definition. Don't use +# gmake-isms. +FASSRC = base.lsp ordrules.lsp locref.lsp idxstyle.lsp \ + index.lsp version.lsp markup.lsp + +FAS = base.fas ordrules.fas locref.fas idxstyle.fas \ + index.fas version.fas markup.fas + +FASLIBS = base.lib ordrules.lib locref.lib idxstyle.lib \ + index.lib version.lib markup.lib + +DEFAULTS = defaults.xdy +DUMP_XINDY = dump-xindy.lsp +MEMFILE = xindy.mem +EXTRA_DIST = $(DEFAULTS).in $(FASSRC) dump-xindy.lsp +SUFFIXES = .fas .lsp +CLEANFILES = $(FAS) $(FASLIBS) $(DEFAULTS) xindy.mem +all: all-am + +.SUFFIXES: +.SUFFIXES: .fas .lsp +$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) + @for dep in $?; do \ + case '$(am__configure_deps)' in \ + *$$dep*) \ + ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ + && { if test -f $@; then exit 0; else break; fi; }; \ + exit 1;; \ + esac; \ + done; \ + echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign xindy/src/Makefile'; \ + $(am__cd) $(top_srcdir) && \ + $(AUTOMAKE) --foreign xindy/src/Makefile +.PRECIOUS: Makefile +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + @case '$?' in \ + *config.status*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ + *) \ + echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ + esac; + +$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh + +$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(am__aclocal_m4_deps): +install-memDATA: $(mem_DATA) + @$(NORMAL_INSTALL) + test -z "$(memdir)" || $(MKDIR_P) "$(DESTDIR)$(memdir)" + @list='$(mem_DATA)'; test -n "$(memdir)" || list=; \ + for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + echo "$$d$$p"; \ + done | $(am__base_list) | \ + while read files; do \ + echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(memdir)'"; \ + $(INSTALL_DATA) $$files "$(DESTDIR)$(memdir)" || exit $$?; \ + done + +uninstall-memDATA: + @$(NORMAL_UNINSTALL) + @list='$(mem_DATA)'; test -n "$(memdir)" || list=; \ + files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ + test -n "$$files" || exit 0; \ + echo " ( cd '$(DESTDIR)$(memdir)' && rm -f" $$files ")"; \ + cd "$(DESTDIR)$(memdir)" && rm -f $$files +tags: TAGS +TAGS: + +ctags: CTAGS +CTAGS: + + +distdir: $(DISTFILES) + @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + list='$(DISTFILES)'; \ + dist_files=`for file in $$list; do echo $$file; done | \ + sed -e "s|^$$srcdirstrip/||;t" \ + -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ + case $$dist_files in \ + */*) $(MKDIR_P) `echo "$$dist_files" | \ + sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ + sort -u` ;; \ + esac; \ + for file in $$dist_files; do \ + if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ + if test -d $$d/$$file; then \ + dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ + if test -d "$(distdir)/$$file"; then \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ + cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ + else \ + test -f "$(distdir)/$$file" \ + || cp -p $$d/$$file "$(distdir)/$$file" \ + || exit 1; \ + fi; \ + done +check-am: all-am +check: check-am +all-am: Makefile $(DATA) +installdirs: + for dir in "$(DESTDIR)$(memdir)"; do \ + test -z "$$dir" || $(MKDIR_P) "$$dir"; \ + done +install: install-am +install-exec: install-exec-am +install-data: install-data-am +uninstall: uninstall-am + +install-am: all-am + @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am + +installcheck: installcheck-am +install-strip: + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + `test -z '$(STRIP)' || \ + echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install +mostlyclean-generic: + +clean-generic: + -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) + +distclean-generic: + -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) + -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) + +maintainer-clean-generic: + @echo "This command is intended for maintainers to use" + @echo "it deletes files that may require special tools to rebuild." +clean: clean-am + +clean-am: clean-generic mostlyclean-am + +distclean: distclean-am + -rm -f Makefile +distclean-am: clean-am distclean-generic + +dvi: dvi-am + +dvi-am: + +html: html-am + +html-am: + +info: info-am + +info-am: + +install-data-am: install-memDATA + +install-dvi: install-dvi-am + +install-dvi-am: + +install-exec-am: + +install-html: install-html-am + +install-html-am: + +install-info: install-info-am + +install-info-am: + +install-man: + +install-pdf: install-pdf-am + +install-pdf-am: + +install-ps: install-ps-am + +install-ps-am: + +installcheck-am: + +maintainer-clean: maintainer-clean-am + -rm -f Makefile +maintainer-clean-am: distclean-am maintainer-clean-generic + +mostlyclean: mostlyclean-am + +mostlyclean-am: mostlyclean-generic + +pdf: pdf-am + +pdf-am: + +ps: ps-am + +ps-am: + +uninstall-am: uninstall-memDATA + +.MAKE: install-am install-strip + +.PHONY: all all-am check check-am clean clean-generic distclean \ + distclean-generic distdir dvi dvi-am html html-am info info-am \ + install install-am install-data install-data-am install-dvi \ + install-dvi-am install-exec install-exec-am install-html \ + install-html-am install-info install-info-am install-man \ + install-memDATA install-pdf install-pdf-am install-ps \ + install-ps-am install-strip installcheck installcheck-am \ + installdirs maintainer-clean maintainer-clean-generic \ + mostlyclean mostlyclean-generic pdf pdf-am ps ps-am uninstall \ + uninstall-am uninstall-memDATA + + +xindy.mem: $(DEFAULTS) $(FAS) $(DUMP_XINDY) + rm -f $(MEMFILE) + $(CLISP) $(srcdir)/$(DUMP_XINDY) + if test "$(host_os)" != "mingw32"; then \ + gzip -9n $@; \ + mv $@.gz $@; \ + fi + +$(DEFAULTS): $(DEFAULTS).in Makefile + sed 's|@MODULEDIR[@]|$(MODULEDIR)|g' <$(srcdir)/$(DEFAULTS).in >$(DEFAULTS) +.lsp.fas: + $(CLISP) -c $< -o $@ + +# Dependencies required for parallel make. +markup.fas: index.fas version.fas +index.fas: idxstyle.fas ordrules.fas +idxstyle.fas: locref.fas +locref.fas: base.fas + +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/Build/source/utils/xindy/xindy-2.4/src/base.lsp b/Build/source/utils/xindy/xindy-2.4/src/base.lsp new file mode 100644 index 00000000000..4158d212f7b --- /dev/null +++ b/Build/source/utils/xindy/xindy-2.4/src/base.lsp @@ -0,0 +1,237 @@ +;; line 30 "base.nw" +(lisp:defpackage "BASE") +(lisp:in-package "BASE") +(lisp:provide "base") + +#+:CMU17 (defpackage "CLOS") + +(eval-when (compile load eval) + (lisp:use-package "CLOS") + (lisp:use-package "COMMON-LISP") + #+CLISP (lisp:use-package "EXT") + ) + +(eval-when (eval load compile) + #+CLISP (when (find-package "XP") + (pushnew :XP *features*)) + #+(or ALLEGRO :CMU17) (pushnew :XP *features*) + ) + +(setq *print-pretty* t) +(setq *print-escape* t) + +(defparameter *mappings-trace* nil) +(defparameter *locref-trace* nil) +(eval-when (compile load eval) + (export '(*mappings-trace* *locref-trace*))) + +;; line 104 "base.nw" +#-CLISP +(defmacro simple-condition-format-string (&rest args) + `(simple-condition-format-control ,@args)) +#-CLISP +(eval-when (compile load eval) + (export '(simple-condition-format-string))) +;; line 133 "base.nw" +(defmacro info (&rest msg) + `(APPLY #'FORMAT *STANDARD-OUTPUT* (LIST ,@msg))) +;; line 138 "base.nw" +(defparameter *nraw-error-message* "~&WARNING: ") + +(defmacro nraw (&rest msg) + `(PROGN + (FORMAT *ERROR-OUTPUT* BASE::*NRAW-ERROR-MESSAGE*) + (APPLY #'FORMAT *ERROR-OUTPUT* (LIST ,@msg)))) +;; line 147 "base.nw" +(defparameter *oops-error-message* "~&ERROR: ") + +(defmacro oops (&rest msg) + `(LET ((MSG (LIST ,@msg))) + (FORMAT *ERROR-OUTPUT* BASE::*OOPS-ERROR-MESSAGE*) + (APPLY #'FORMAT *ERROR-OUTPUT* MSG) + (WHEN *LOGGING-ON* + (FORMAT *LOGGING-STREAM* BASE::*OOPS-ERROR-MESSAGE*) + (APPLY #'FORMAT *LOGGING-STREAM* MSG)))) +;; line 162 "base.nw" +(defmacro oops* (fmt args) + `(LET ((FMT ,fmt) + (ARGS ,args)) + (FORMAT *ERROR-OUTPUT* BASE::*OOPS-ERROR-MESSAGE*) + (APPLY #'FORMAT *ERROR-OUTPUT* FMT ARGS) + (WHEN *LOGGING-ON* + (FORMAT *LOGGING-STREAM* BASE::*OOPS-ERROR-MESSAGE*) + (APPLY #'FORMAT *LOGGING-STREAM* FMT ARGS)))) +;; line 183 "base.nw" +(defparameter *logging-stream* nil) +(defparameter *logging-on* nil) + +(defmacro gol (flag &rest msg) + `(WHEN (AND ,flag *LOGGING-ON*) + (APPLY #'FORMAT *LOGGING-STREAM* (list ,@msg)))) +;; line 74 "base.nw" +(defmacro ifnot (expr then-body else-body) + `(IF (NOT ,expr) ,then-body ,else-body)) +;; line 82 "base.nw" +(defun error-exit () + #+CLISP (exit 1) + #+ALLEGRO (excl:exit 1) + #+CMU17 (unix:unix-exit 1) + ) + +(defun exit-normally () + #+CLISP (exit 0) + #+ALLEGRO (excl:exit 0) + #+CMU17 (unix:unix-exit 0) + ) +;; line 201 "base.nw" +(defmacro assert! (cond &optional msg) + `(UNLESS ,cond + (FORMAT *ERROR-OUTPUT* "Internal error! Assertion ~A failed!" ',cond) + ,(if msg + `(ERROR "~S" ,msg) + `(ERROR "Entering debugger!")))) + +(pushnew :ASSERT! *features*) +;; line 218 "base.nw" +(defmacro define-slot-accessors (accessors) + `(eval-when (compile load eval) + ,@(apply #'nconc + (mapcar + #'(lambda (acc) + (let ((getnam (intern (concatenate 'string "GET-" + (symbol-name acc)))) + (setnam (intern (concatenate 'string "SET-" + (symbol-name acc)))) + ) + `((defmacro ,getnam (obj) + (list 'slot-value obj '',acc)) + (defmacro ,setnam (val obj) + (list 'setf (list 'slot-value obj '',acc) val)) + (export '(,getnam ,setnam ,acc))))) + accessors)))) + +(define-slot-accessors ( + attribute + base-alphabet + basetype + catattr + catattr-grp-ordnum + entries + entry-list + entry-table + first + group-definition + hierdepth + idxclass + inner + join-length + last + last-in-group + layers + length + letters + locclass + locref-cache + locref-string + locrefs + members + merge-key + sort-key + print-key + main-key + name + order + ordnum + ordnums + origin + processing-ordnum + props + rangeattr + separator + sort-ordnum + state + subentries + subrefs + symbols + target + type + )) +;; line 297 "base.nw" +(defun split-list (split-function list &key sortfunc headfunc) + #+:ASSERT! (assert (not (and sortfunc headfunc)) + () + "split-list") + (let ((list-len (length list))) + (if (= 1 list-len) + (list list) + (let ((split-table (make-hash-table :test #'equal + :size (round (* 1.2 list-len)))) + (key-list '())) + (mapc #'(lambda (elt) + (let ((key (funcall split-function elt))) + (setf (gethash key split-table) + (cons elt (gethash key split-table))))) + list) + (maphash #'(lambda (key element) + (declare (ignore element)) + (push key key-list)) + split-table) + (maplist #'(lambda (rest-list) + (let ((entries (gethash (car rest-list) split-table))) + (if headfunc + (let ((head (find-if headfunc entries))) + (rplaca rest-list + (if head + (cons head (delete head entries)) + entries))) + (rplaca rest-list entries)))) + (if sortfunc (sort key-list sortfunc) key-list)) + key-list)))) + +#| +This version seems to be a little bit slower than the above one, +despite the fact that we use a temporary array with a fill-pointer. + +(defun split-list (split-function sort-function list) + (let ((list-len (length list))) + (if (= 1 list-len) + (list list) + (let ((split-table (make-hash-table :test #'equal + :size (round (* 1.5 list-len))))) + (mapc #'(lambda (elt) + (let ((key (funcall split-function elt))) + (setf (gethash key split-table) + (cons elt (gethash key split-table))))) + list) + (let ((sort-array (make-array (hash-table-count split-table) + :fill-pointer 0))) + (maphash #'(lambda (key element) + (declare (ignore element)) + (vector-push key sort-array)) + split-table) + (map 'list + #'(lambda (key) + (gethash key split-table)) + (sort sort-array sort-function))))))) +|# + +;; line 60 "base.nw" +(defvar *RCS-Identifier* '( +;; line 68 "base.nw" +("base" . "$Id: base.nw,v 1.20 1997/03/26 16:17:58 kehr Exp $") +;; line 60 "base.nw" + )) + +(eval-when (compile load eval) + +;; line 96 "base.nw" +(export '(ifnot error-exit exit-normally)) +;; line 192 "base.nw" +(export '(oops oops* nraw info gol + *logging-stream* *logging-on*)) +;; line 212 "base.nw" +(export 'assert!) +;; line 357 "base.nw" +(export '(split-list)) +;; line 64 "base.nw" + ) diff --git a/Build/source/utils/xindy/xindy-2.4/src/defaults.xdy.in b/Build/source/utils/xindy/xindy-2.4/src/defaults.xdy.in new file mode 100644 index 00000000000..bd149fdbae0 --- /dev/null +++ b/Build/source/utils/xindy/xindy-2.4/src/defaults.xdy.in @@ -0,0 +1,5 @@ +;; defaults.xdy.in 29 Mar 09 -*- Lisp -*- +;;------------------------------------------------------------ + +(setq *load-paths* (list (pathname ".") + (pathname "@MODULEDIR@"))) diff --git a/Build/source/utils/xindy/xindy-2.4/src/dump-xindy.lsp b/Build/source/utils/xindy/xindy-2.4/src/dump-xindy.lsp new file mode 100644 index 00000000000..73dc63677bd --- /dev/null +++ b/Build/source/utils/xindy/xindy-2.4/src/dump-xindy.lsp @@ -0,0 +1,33 @@ +;; $Id: dump-xindy.xdy,v 1.2 1996/08/02 17:41:07 kehr Exp $ +;; ---------------------------------------------------------------------- +;; +;; This file is necessary to dump xindy. +;; + +#+CLISP (setq custom:*suppress-check-redefinition* t) + +(load 'base) +(load 'locref) +(load 'ordrules) +(load 'idxstyle) +(load 'index) +(load 'version) +(load 'markup) + +(load "defaults.xdy") + +(setq *load-verbose* nil) + +(shadow 'require) +(lisp:shadowing-import idxstyle:*idxstyle-user-interface-definitions*) +(lisp:import markup:*markup-user-interface-definitions*) +(lisp:import index:*raw-index-interface-definitions*) + +;; Install the break-driver if its feature exists. +#+:BREAK-DRIVER +(setq *break-driver* #'xindy:*break-driver*) + +(gc) + +(saveinitmem "xindy.mem" :quiet t) +(exit) diff --git a/Build/source/utils/xindy/xindy-2.4/src/idxstyle.lsp b/Build/source/utils/xindy/xindy-2.4/src/idxstyle.lsp new file mode 100644 index 00000000000..2a561aee7f9 --- /dev/null +++ b/Build/source/utils/xindy/xindy-2.4/src/idxstyle.lsp @@ -0,0 +1,2127 @@ +;; line 289 "idxstyle.nw" +;; $Id: idxstyle.nw,v 1.19 1997/03/26 16:18:23 kehr Exp $ +;; + +(lisp:defpackage "IDXSTYLE") +(lisp:in-package "IDXSTYLE") +(lisp:provide "idxstyle") + +#+CLISP (lisp:require "base") +#+CLISP (lisp:require "locref") +#+CLISP (lisp:require "ordrules") + +(eval-when (compile load eval) + (lisp:use-package "CLOS") + (lisp:use-package "COMMON-LISP") + #+CLISP (lisp:use-package "EXT") + #+(and :XP CLISP) (lisp:use-package "XP") + #-CLISP (lisp:require "base") + #-CLISP (lisp:require "locref") + (lisp:use-package "BASE") + (lisp:use-package "LOCREF") + +;; line 472 "intface.nw" +(eval-when (eval load compile) + (when (find-package "ORDRULES") + (pushnew :ORDRULES *features*))) +;; line 306 "idxstyle.nw" + ;; see submodule intface + ) + +;; line 78 "idxstyle.nw" +(defparameter *indexstyle* nil) +(defparameter *indexstyle-readtable* (copy-readtable)) +(defparameter *included-files* '()) +(defvar *load-paths* "") +(defparameter *default-load-paths* *load-paths*) + +(defparameter *default-minimum-range-length* 2) +(defparameter *default-locref-hierdepth* 0) + +;; line 1151 "intface.nw" +;; $Id: intface.nw,v 1.30 1997/10/20 11:25:09 kehr Exp $ + +;; line 1016 "intface.nw" +;;; $Id: intface.nw,v 1.30 1997/10/20 11:25:09 kehr Exp $ +;;;---------------------------------------------------------------------- + +;;; +;;; util-lib LISP Utitlity Library +;;; +;;; (history at end) + + +;(provide 'util-lib) +;(in-package 'util-lib) + +(defvar whole) +(eval-when (compile load eval) + (export '(destructuring-switch-bind &switch whole))) + +(defmacro destructuring-switch-bind (lambdalist expr . body) + "Similar to 'destructuring-bind' but also allows switch options at the +end of LAMBDALIST with the following syntax: + + &switch { var | (var key [defval]) | (var ({ key }*) [defval]) }* + +In all cases VAR will be accessible in BODY as a variable. + +If only VAR is specified, it is bound to the keyword with the same +name, if that keyword occured in EXPR. Otherwise it is bound to NIL. + +If both a VAR and KEY were specified, VAR will be bound to KEY, if KEY +occured in EXPR and to NIL otherwise. + +If VAR and a list of KEYs were specified, VAR will be bound to the +first KEY, which occured in EXPR. If none of the KEYS occured within +EXPR, VAR will be bound to NIL. + +If DEFVAL was specified, variable will be bound to DEFVAL instead of +NIL in cases where no switch keyword was found in EXPR. +" + + (let* ((switchlist (member '&switch lambdalist)) + + ;; 'remove' switches from lambdalist + (lambdalist (ldiff lambdalist switchlist)) + + ;; drop &switch keyword + (switches (when switchlist (cdr switchlist))) + + ;; construct bindings for each switch and collect valid + ;; keywords in 'switchkeys' + (switchkeys '()) + (bindings + (mapcar + #'(lambda (spec) + (cond + + ;; spec simply consists of VAR + ((symbolp spec) + (let ((key (intern (symbol-name spec) 'keyword))) + (push key switchkeys) + `(,spec (FIND ,key <DESTRUCTURING-SWITCH-FORM>)) + )) + + ;; spec is (VAR form) + ((and (listp spec) (>= (list-length spec) 2)) + (let ((var (first spec)) + (keyspec (second spec)) + (defval (when (cddr spec) (third spec)))) + (cond + ;; spec is (VAR (KEY1 KEY2 ...)) + ((listp keyspec) + `(,var + (COND + ,@(mapcar + #'(lambda (key) + (push key switchkeys) + `((FIND ,key <DESTRUCTURING-SWITCH-FORM>) + ,key)) + keyspec) + (T ,defval)))) + + ;; spec is (VAR KEY) + (t + (push keyspec switchkeys) + ` (,var (OR + (FIND ,keyspec <DESTRUCTURING-SWITCH-FORM>) + ,defval))) + ))) + + ;; illegal spec + (t (error "~A is not a valid switch specifier." spec)) + )) + switches)) + ) + + ;; construct the expansion form + ` (LET ((<DESTRUCTURING-SWITCH-FORM> ,expr)) + (LET ,bindings + (HANDLER-CASE + (DESTRUCTURING-BIND ,lambdalist + (SET-DIFFERENCE-KEEP-ORIGINAL-ORDER + <DESTRUCTURING-SWITCH-FORM> + ',switchkeys) + ,@body) + (ERROR (COND) + (DECLARE (IGNORE COND)) + (ERROR "~&Syntax Error in ~S." WHOLE) + ) + ) + ) + ) + )) + +(defun set-difference-keep-original-order (set1 set2) + (mapcan #'(lambda (elt) + (unless (member elt set2) + (list elt))) + set1)) + +#| +(destructuring-switch-bind (name &rest args &key foo bar + &switch + on ; simple form + (started :start) + (speed (:fast :slow)) + (off :turn-off :turn-on) ; with switch key + (choose (:one :two :three) :three)) + '(width :foo 5 :bar 7 :on :turn-off :one) + (list name foo bar args on started speed off choose)) +|# +;; line 111 "intface.nw" +(eval-when (compile load eval) + (defun stringify (name) + (declare (inline)) + (etypecase name + (symbol (symbol-name name)) + (string name) + (number (write-to-string name))))) + +(defun list-of-strings-p (x) + (cond ((not (listp x)) nil) + ((every #'(lambda (elt) + (or (stringp elt) (symbolp elt) (numberp elt))) + x)))) +;; line 136 "intface.nw" +(defun make-well-formed-list (attr-list) + (mapcar #'(lambda (x) + (cond ((null x) + (error "empty lists are not allowed !")) + ((or (symbolp x) (stringp x) (numberp x)) + (list (stringify x))) + ((listp x) + (map-to-strings x)))) + attr-list)) + +(defun map-to-strings (slist) + (mapcar #'(lambda (x) + (cond ((null x) + (error "empty lists are not allowed !")) + ((or (symbolp x) (stringp x) (numberp x)) + (stringify x)) + ((listp x) + (error "nesting level too deep !")) + (t (error "~S is not a string !" x)))) + slist)) +;; line 185 "intface.nw" +(defun c-string-reader (stream char) + (declare (ignore char)) + (let ((ch nil) + (str (make-array 32 + :element-type + #+CLISP 'string-char + #-CLISP 'base-char + :adjustable t + :fill-pointer 0))) + (loop + (setq ch (read-char stream t #\Newline t)) + (case ch + (#\" (let ((nextch (read-char-no-hang stream t #\Newline t))) + (when nextch + (unread-char nextch stream) + (case nextch + (#\Newline) + (#\t) + (#\Space) + (#\)) + (t (nraw "~&Possible read-error due to ill-formed string \"~A\" ~S" + str *)))) + (return str))) + (#\~ (setq ch (read-char stream t #\Newline t)) + (case ch + (#\n (vector-push-extend #\Newline str)) + (#\t (vector-push-extend #\Tab str)) + (#\b (vector-push-extend (character 1) str)) + (#\e (vector-push-extend (character 255) str)) + (t (vector-push-extend ch str)))) + (t (vector-push-extend ch str)))))) + +(set-macro-character #\" #'c-string-reader nil *indexstyle-readtable*) + +#| +(let ((x #\Null)) + (loop for i from 1 to 255 + do (progn (print (character i)) + (when (char>= x (character i)) + (print "Whee!")) + (setq x (character i))))) +|# +;; line 254 "intface.nw" +(defmacro define-alphabet (&whole whole &optional name string-list) + (cond +;; line 239 "intface.nw" +((null name) + (error "missing argument <name> in `~S' !" whole)) +((not (or (symbolp name) (stringp name))) + (error "~S is not a symbol or a string in `~S' !" name whole)) +;; line 256 "intface.nw" + ((not (listp string-list)) + (error "missing argument <string-list> !")) + ((not (list-of-strings-p string-list)) + (error "~S is not a list of strings" string-list)) + (t `(LET ((NAME (STRINGIFY ',name))) + (WHEN (LOOKUP-BASETYPE *indexstyle* NAME) + (NRAW "redefining alphabet `~S'" NAME)) + (ADD *indexstyle* (MAKE-ALPHABET NAME ',string-list)))))) + +(defmacro define-alphabet* (&whole whole &optional name string-list) + (cond +;; line 239 "intface.nw" +((null name) + (error "missing argument <name> in `~S' !" whole)) +((not (or (symbolp name) (stringp name))) + (error "~S is not a symbol or a string in `~S' !" name whole)) +;; line 267 "intface.nw" + ((not (listp string-list)) + (error "missing argument <string-list> !")) + (t (let ((scar (car string-list))) + (if (and (symbolp scar) (fboundp scar)) + `(LET ((NAME (STRINGIFY ',name)) + (STRING-LIST ,string-list)) #| evaluates string-list |# + (UNLESS (LIST-OF-STRINGS-P STRING-LIST) + (ERROR "~S is not a list of strings" STRING-LIST)) + (WHEN (LOOKUP-BASETYPE *indexstyle* NAME) + (NRAW "redefining alphabet `~S'" NAME)) + (ADD *indexstyle* (MAKE-ALPHABET NAME STRING-LIST)))))))) +;; line 284 "intface.nw" +(defmacro define-enumeration (&whole + whole + &optional + name prefix-match-func base-alphabet) + (cond +;; line 239 "intface.nw" +((null name) + (error "missing argument <name> in `~S' !" whole)) +((not (or (symbolp name) (stringp name))) + (error "~S is not a symbol or a string in `~S' !" name whole)) +;; line 289 "intface.nw" + ((null prefix-match-func) + (error "missing argument <prefix-match-function> !")) + (t (let* ((name (stringify name)) + (symbol (make-symbol + (concatenate 'string "ENUMERATION-" name)))) + `(LET () #| PROGN instead of LET () yields a runtime error !? |# + (IF (LOOKUP-BASETYPE *indexstyle* ,name) + (NRAW "redefining alphabet `~S'" ,name) + (PROGN + (DEFCLASS ,symbol (ENUMERATION) ()) + (ADD *indexstyle* + (MAKE-ENUMERATION ',symbol ,name ,base-alphabet)))) + (DEFMETHOD PREFIX-MATCH ((STR STRING) (ENUM ,symbol)) + (FUNCALL ,prefix-match-func STR))))))) +;; line 312 "intface.nw" +(defmacro define-location-class (&whole whole &rest args) + (destructuring-switch-bind (name + layer-list + &key + (min-range-length *default-minimum-range-length*) + (hierdepth 0) ;no hierarchies are to be formed + &switch + (var :var)) + args + (cond + ((null name) + (error "missing argument <name> in~%~S" whole)) + ((null layer-list) + (error "missing argument <layer-list> in~%~S" whole)) + ;;((not (list-of-strings-p layer-list)) + ;; (error "~S is not a list of strings in~%~S" layer-list whole)) + ((not (numberp hierdepth)) + (error "~S is not a number! in~%~S" hierdepth whole)) + ((not (or (numberp min-range-length) + (eql 'none min-range-length))) + (error "~S must be a number or the keyword `none' in~%~S" + min-range-length whole)) + (t (when (eql 'none min-range-length) + (setq min-range-length 0)) + `(LET ((NAME (STRINGIFY ',name)) + (LAYERS (BUILD-LOCCLASS-LAYERS ',layer-list ',whole))) + ;;(GOL T "~&define-location-class: ~S" LAYERS) + (COND ((LOOKUP-CROSSREF-CLASS *indexstyle* NAME) + (OOPS "replacing cross-reference-class `~S' is not allowed !" + NAME)) + (t (WHEN (LOOKUP-LOCATION-CLASS *indexstyle* NAME) + (NRAW "redefining location-reference-class `~S' !" NAME)) + (ADD *indexstyle* + ,(if var + `(CHECKED-MAKE-VAR-LOCATION-CLASS NAME LAYERS + ,hierdepth) + `(CHECKED-MAKE-STANDARD-LOCATION-CLASS NAME LAYERS + ,min-range-length ,hierdepth)))) + )))))) +;; line 354 "intface.nw" +(defun build-locclass-layers (layers whole) + (let ((res-list '())) + (loop + ;;(gol t "~&build-locclass-layers: ~S" layers) + (when (endp layers) (return (nreverse res-list))) + (cond ((eql :sep (car layers)) + (setq layers (cdr layers)) + (if (endp layers) + (error "Reached end of list in~%~S" whole) + (push (make-loccls-separator (stringify (car layers))) + res-list))) + (t (let* ((layer (stringify (car layers))) + (basetype (lookup-basetype *indexstyle* layer))) + (if basetype + (push (make-loccls-layer basetype) res-list) + (error "Unknown basetype ~S in~%~S" layer whole))))) + (setq layers (cdr layers))))) +;; line 377 "intface.nw" +(defmacro define-crossref-class (&whole whole &rest args) + (destructuring-switch-bind (name + &switch (verified :unverified)) + args + (cond +;; line 239 "intface.nw" +((null name) + (error "missing argument <name> in `~S' !" whole)) +((not (or (symbolp name) (stringp name))) + (error "~S is not a symbol or a string in `~S' !" name whole)) +;; line 382 "intface.nw" + (t `(LET ((NAME (STRINGIFY ',name))) + (cond ((LOOKUP-LOCATION-CLASS *indexstyle* NAME) + (OOPS "replacing location-reference-class `~S' is not allowed !" + NAME)) + (t (WHEN (LOOKUP-CROSSREF-CLASS *indexstyle* NAME) + (NRAW "redefining crossref-location-class `~S'" NAME)) + (ADD *indexstyle* + ,(if verified + `(MAKE-UNVERIFIED-CROSSREF-LOCATION-CLASS NAME) + `(MAKE-VERIFIED-CROSSREF-LOCATION-CLASS NAME)))))))))) +;; line 398 "intface.nw" +(defmacro define-location-class-order (olist) + (cond ((not (listp olist)) + (error "missing argument <list> !")) + ((not (list-of-strings-p olist)) + (error "~S is not a list of strings" olist)) + (t `(LET ((CTR 1)) + (MAPC #'(LAMBDA (NAME) + (LET* ((NEW-NAME (STRINGIFY NAME)) + (LOCCLS + (CDR (LOOKUP-LOCATION-CLASS *indexstyle* + NEW-NAME)))) + (INCF CTR) + (COND (LOCCLS (SET-ORDNUM CTR LOCCLS)) + (t (OOPS "unknown location-class `~S'" + NEW-NAME))))) + ',olist))))) +;; line 423 "intface.nw" +(defmacro define-attributes (&whole whole &optional attr-list) + (cond ((null attr-list) + (error "missing argument <attribute-list> in~&~S" whole)) + (t (let* ((wf-attr-list (make-well-formed-list attr-list)) + (plain-list (apply #'concatenate 'list wf-attr-list)) + ) + `(PROGN + (MAPCAR + #'(LAMBDA (CATATTR) + (IF (LOOKUP-CATATTR *indexstyle* CATATTR) + (NRAW "ignoring redefinition of attribute ~S in~&~S" + CATATTR ',whole) + (ADD *indexstyle* + (MAKE-CATEGORY-ATTRIBUTE CATATTR)))) + ',plain-list) + (INITIALIZE-CATEGORY-ATTRIBUTES ',wf-attr-list *indexstyle*)) + )))) +;; line 488 "intface.nw" +#+:ORDRULES +(defmacro merge-rule (&whole whole &rest args) + (destructuring-switch-bind (pattern + replacement + &switch + (again :again) + (string :string) + (extended-regexp :eregexp) + (basic-regexp :bregexp)) + args + (cond ((null pattern) + (error "missing argument <pattern> !")) + ((or (and string extended-regexp) (and string basic-regexp) + (and extended-regexp basic-regexp)) + (error "~&Only one of (:string :bregexp :eregexp) allowed in:~&~S !" + whole)) + ((null replacement) + (error "~&Missing argument <replacement> in:~&~S!" whole)) + (t `(PROGN + (ORDRULES:ADD-KEYWORD-MERGE-RULE ,pattern ,replacement + ,(if again 1 0) + ,(cond (string 1) + (basic-regexp 2) + (extended-regexp 3) + (t 0))) + (FLUSH-ORDRULES-MESSAGE-BUFFER)))))) + +#-:ORDRULES +(defmacro merge-rule (&rest args) + (declare (ignore args)) + (oops "merge-rule not supported! ignoring definition")) +;; line 525 "intface.nw" +#+:ORDRULES +(defparameter *sort-rule-orientations* + '(forward forward forward forward + forward forward forward forward)) + +#+:ORDRULES +(defmacro define-sort-rule-orientations (&whole whole &rest args) + (destructuring-switch-bind (&optional + (orientations *sort-rule-orientations*)) + args + (unless (every #'(lambda (run) + (member run '(forward backward))) + orientations) + (error "~&Elements of ~S must be one of {forward,backward}!" + orientations)) + `(PROGN + (SETQ *SORT-RULE-ORIENTATIONS* ',orientations) + (ORDRULES:INITIALIZE (LENGTH *SORT-RULE-ORIENTATIONS*)) + (FLUSH-ORDRULES-MESSAGE-BUFFER)))) + +#+:ORDRULES +(defmacro define-rule-set (&whole whole &rest args) + (destructuring-bind (&optional + name + &key + inherit-from + rules) + args + (cond +;; line 239 "intface.nw" +((null name) + (error "missing argument <name> in `~S' !" whole)) +((not (or (symbolp name) (stringp name))) + (error "~S is not a symbol or a string in `~S' !" name whole)) +;; line 554 "intface.nw" + ((not (listp rules)) + (error "missing argument <rules-list> !")) + (t `(LET ((RS (MAKE-RULE-SET ',name ',inherit-from ',rules))) + (MAPC #'(LAMBDA (INH-NAME) + (INHERIT-RULE-SET RS (LOOKUP-RULE-SET *INDEXSTYLE* + INH-NAME))) + ',inherit-from) + (ADD-RULE-SET *INDEXSTYLE* RS)))))) + +#-:ORDRULES +(defmacro define-rule-set (&rest args) + (declare (ignore args)) + (oops "define-rule-sets not supported! ignoring definition")) + +#+:ORDRULES +(defmacro use-rule-set (&whole whole &rest args) + ;; FIXME: if we use destructuring-switch-bind-here an error occurs + (destructuring-bind (&key + run + rule-set) + args + (cond ((not (integerp run)) + (error "incorrect argument <run> !")) + ((not rule-set) + (error "missing argument <rule-set> !")) + ((not (or (listp rule-set) + (stringp rule-set))) + (error "wrong argument to <rule-set> !")) + (t `(INSTANTIATE-RULE-SET ,run ,rule-set))))) + +#-:ORDRULES +(defmacro use-rule-set (&rest args) + (declare (ignore args)) + (oops "use-rule-sets not supported! ignoring definition")) + +#+:ORDRULES +(defmacro sort-rule (&whole whole &rest args) + (destructuring-switch-bind (pattern + replacement + &key + (run 0) + &switch + (again :again) + (string :string) + (extended-regexp :eregexp) + (basic-regexp :bregexp)) + args + (cond ((null pattern) + (error "missing argument <pattern> !")) + ((or (< run 0) (>= run (length *sort-rule-orientations*))) + (error "~&Argument of :run must be in the interval [0..~A]!" + (length *sort-rule-orientations*))) + ((or (and string extended-regexp) (and string basic-regexp) + (and extended-regexp basic-regexp)) + (error "~&Only one of (:string :bregexp :eregexp) allowed in:~&~S !" + whole)) + ((null replacement) + (error "missing argument <replacement> !")) + (t `(PROGN + (ORDRULES:ADD-KEYWORD-SORT-RULE ,run ,pattern ,replacement + ,(if again 1 0) + ,(cond (string 1) + (basic-regexp 2) + (extended-regexp 3) + (t 0))) + (FLUSH-ORDRULES-MESSAGE-BUFFER)))))) + +#-:ORDRULES +(defmacro define-sort-rule-orientations (&rest args) + (declare (ignore args)) + (oops "define-sort-rule-orientations not supported! ignoring definition")) + +#-:ORDRULES +(defmacro sort-rule (&rest args) + (declare (ignore args)) + (oops "sort-rule not supported! ignoring definition")) + +(defun flush-ordrules-message-buffer () + #+:ORDRULES + (when (and *mappings-trace* ordrules::*message-logging*) + (gol t "~A" ordrules::*message-buffer*) + (setq ordrules::*message-buffer-ptr* 0))) +;; line 696 "intface.nw" +(defmacro define-letter-group + (&whole whole name &key prefixes before after) + (cond +;; line 239 "intface.nw" +((null name) + (error "missing argument <name> in `~S' !" whole)) +((not (or (symbolp name) (stringp name))) + (error "~S is not a symbol or a string in `~S' !" name whole)) +;; line 699 "intface.nw" + ((and before + (not (lookup-letter-group-definition *indexstyle* before))) + (error "~S does not name a letter group in~%~S" before whole)) + ((and after + (not (lookup-letter-group-definition *indexstyle* after))) + (error "~S does not name a letter group in~%~S" after whole)) + ((not (list-of-strings-p prefixes)) + (error "argument <prefixes> is not a list of strings in~%~S" + whole)) + (t `(LET () + (ADD-LETTER-GROUPS *INDEXSTYLE* + ,name ',(or prefixes (list name)) + :BEFORE ,before :AFTER ,after))))) +;; line 718 "intface.nw" +(defmacro define-letter-groups (&whole whole &optional letter-groups) + (cond ((not (list-of-strings-p letter-groups)) + (error "~S is not a list of strings in~%~S" letter-groups whole)) + (t `(LET () + (ADD-LETTER-GROUPS *INDEXSTYLE* + ,(car letter-groups) ',(list (car letter-groups))) + ,@(let ((last (car letter-groups))) + (mapcar #'(lambda (letter-group) + (prog1 + `(ADD-LETTER-GROUPS *INDEXSTYLE* + ,letter-group ',(list letter-group) + :AFTER ,last) + (setq last letter-group))) + (cdr letter-groups))))))) +;; line 650 "intface.nw" +(defmacro merge-to (&whole whole &rest args) + (destructuring-switch-bind (from to &switch drop) + args + (let ((from-attr (lookup-catattr *indexstyle* from)) + (to-attr (lookup-catattr *indexstyle* to))) + (cond ((not from-attr) + (nraw "`~S' is not a known attribute in:~&~A" from whole)) + ((not to-attr) + (nraw "`~S' is not a known attribute in:~&~A" to whole)) + (t (if drop + `(ADD-DROP-IF-MERGED-RULE *INDEXSTYLE* + ',from-attr ',to-attr) + `(ADD-MERGE-RULE *INDEXSTYLE* + ',from-attr ',to-attr))))))) +;; line 740 "intface.nw" +;;; we remove the inherited symbol and establish a new one +(eval-when (compile load eval) + (shadow 'require)) + +(defmacro require (&rest args) + (cond ((null args) + (error "missing argument <filename> !")) + ((not (stringp (car args))) + (error "(require ~S): expected <filename> !" (car args))) + (t `(LET ((FILENAME (STRINGIFY ',(car args)))) + (DO-REQUIRE FILENAME))))) + +(defun do-require (filename) + (let ((file (find-file filename))) + (unless (member file *included-files* :test #'equalp) + (push file *included-files*) + (info "~&Loading module ~S..." filename) + (watched-load file :echo t) + (info "~&Finished loading module ~S.~%" filename)))) + +#| +(defun do-require (filename) + (let ((file (find-file filename))) + (unless (member file *included-files* :test #'equalp) + (push file *included-files*) + (info "~&Loading module ~S..." filename) + (let ((*standard-output* (make-string-output-stream))) + (handler-case + (load file :verbose nil :echo t) +; (stream-error (cond) +; (step +; (progn +; (oops* +; (simple-condition-format-string cond) +; (simple-condition-format-arguments cond)) +; (exit)) +; ) +; ) + (error (condition) + (info "~&~%~A~%" ";;;;;;;;;;;;;;;;;;;;;;;;") + (info "~A~%" ";; ERROR SECTION START") + (info "~%~A~%" (get-output-stream-string *standard-output*)) + (info "~%~A~%" ";; ERROR SECTION END") + (info "~A~%~%" ";;;;;;;;;;;;;;;;;;;;;;;;") + (oops* (simple-condition-format-string condition) + (simple-condition-format-arguments condition)) + (error-exit)) + ) + ) + (info "~&Finished loading module ~S.~%" filename)))) +|# +;; line 802 "intface.nw" +(defun find-file (filename) + (let ((file (parse-namestring filename))) + (when (equal (file-namestring file) "") + (error "~S is not a valid filename !" filename)) + (let ((found (some #'(lambda (path) + (and (probe-file (append-pathnames path file)))) + *load-paths*))) + (or found (error "Could not find file ~S !" filename))))) +;; line 813 "intface.nw" +(defvar *wl-fmt* "~&~%Error in line ~S:~%~A~%") +(defun watched-load (filename + &key + (print *load-print*) + (if-does-not-exist t) + echo) + (let ((stream (open (setq filename (pathname filename)) + :direction + #+CLISP :input-immutable + #-CLISP :input + :element-type + #+CLISP 'string-char + #-CLISP 'base-char + :if-does-not-exist nil)) + (lineno 1)) + (if stream + (let* ((load-stream (make-string-output-stream)) + (input-stream (if echo + (make-echo-stream stream load-stream) + stream + )) + (*load-pathname* (if (pathnamep filename) filename nil)) + (*load-truename* (if (pathnamep filename) (truename filename) nil)) + (*package* *package*) ; *PACKAGE* binden + (*readtable* *readtable*) ; *READTABLE* binden + (end-of-file "EOF")) ; einmaliges Objekt + ;;(setq sys::*load-input-stream* input-stream) + (block nil + (unwind-protect + (tagbody weiter + (let* ((obj + (handler-case (read input-stream nil end-of-file) + (error (cond) + (when echo + (let* ((str (get-output-stream-string load-stream)) + (cnt (count #\Newline str))) + (info *wl-fmt* (+ cnt lineno) str) + (oops* (simple-condition-format-string cond) + (simple-condition-format-arguments cond)) + (error-exit)))))) + (str (get-output-stream-string load-stream)) + (cnt (count #\Newline str))) + (incf lineno cnt) + (when (eql obj end-of-file) + (return-from nil)) + (setq obj + (multiple-value-list + (cond ((compiled-function-p obj) (funcall obj)) + ;;(compiling (funcall (compile-form obj nil nil nil nil nil))) + (t (handler-case (eval obj) + (error (cond) + (info *wl-fmt* lineno str) + (oops* (simple-condition-format-string cond) + (simple-condition-format-arguments cond)) + (error-exit))) + (get-output-stream-string load-stream) + )))) + (when print (when obj (print (first obj)))) + ) + (go weiter) + ) + (close stream) (close input-stream) + ) ) + t) + (if if-does-not-exist + (error "A file with name ~A does not exist" filename) + nil) + ) )) +;; line 891 "intface.nw" +(defmacro searchpath (&rest args) + (cond ((null args) + (error "missing argument <pathlist> !")) + ((stringp (car args)) + `(SET-SEARCHPATH-BY-STRING ,(car args))) + ((listp args) + `(SET-SEARCHPATH ',(car args))))) + +(defun set-searchpath-by-string (searchpath-str) + (set-searchpath (string-to-searchlist searchpath-str))) +;; line 913 "intface.nw" +(defun string-to-searchlist (str) + (let ((paths '()) + pos) + (nreverse + (loop (when (equalp str "") + (return (push :default paths))) + (setq pos (position #+UNIX #\: + #+OS/2 #\; + #+WIN32 #\; + str)) + (if pos + (progn + (push (subseq str 0 pos) paths) + (setq str (subseq str (1+ pos)))) + (return (push str paths))))))) + +(defun set-searchpath (path-list) + (setq *load-paths* + (apply #'nconc + (mapcar + #'(lambda (elt) + (cond ((stringp elt) + (list (make-real-pathname elt))) + ((eq elt :default) + *default-load-paths*) + ((eq elt :last) + *load-paths*) + (t (oops "~&searchpath: invalid argument ~S in~%~S" + elt path-list)))) + path-list)))) +;; line 954 "intface.nw" +#+CLISP +(defun make-real-pathname (pathname-str) + (let* ((pn (pathname pathname-str)) + (fname (file-namestring pn))) + (if (string/= fname "") + (make-pathname :device (pathname-device pn) + :directory (append (or (pathname-directory pn) + '(:relative)) + (list fname))) + pn))) +;; line 966 "intface.nw" +#-CLISP +(defun make-real-pathname (pathname-str) + (let ((pn (parse-namestring + (if (eql (elt pathname-str (1- (length pathname-str))) #\/) + pathname-str + (concatenate 'string pathname-str "/"))))) + (if (pathname-directory pn) + pn + (make-pathname :directory (list :relative (pathname-name pn)))))) +;; line 986 "intface.nw" +(defun append-pathnames (pn-dir pn-sub) + (let ((dir-dir (pathname-directory pn-dir)) + (dir-sub (pathname-directory pn-sub))) + (cond ((eq :absolute (car dir-sub)) pn-sub) + (t (make-pathname :device (pathname-device pn-dir) + :directory (append dir-dir (cdr dir-sub)) + :name (pathname-name pn-sub) + :type (pathname-type pn-sub)))))) + +;; line 62 "intface.nw" +(defparameter *idxstyle-user-interface-definitions* + '( + *default-minimum-range-length* + *included-files* + *indexstyle-readtable* + define-alphabet + define-alphabet* + define-attributes + define-crossref-class + define-enumeration + define-letter-group + define-letter-groups + define-location-class + define-location-class-order + define-rule-set + define-sort-rule-orientations + forward backward + info + merge-rule + merge-to + require + searchpath + sort-rule + use-rule-set + *indexstyle* + )) + +;; line 1168 "intface.nw" +(eval-when (compile load eval) + +;; line 91 "intface.nw" +(export '(*indexstyle* + *indexstyle-readtable* + do-require + set-searchpath-by-string + *sort-rule-orientations* + forward backward + *idxstyle-user-interface-definitions* + )) +;; line 159 "intface.nw" +(export '(stringify list-of-strings-p + make-well-formed-list map-to-strings)) +;; line 642 "intface.nw" +(export 'flush-ordrules-message-buffer) +;; line 1170 "intface.nw" + ) +;; line 557 "idxrule.nw" +;; $Id: idxrule.nw,v 1.10 1997/03/26 16:18:19 kehr Exp $ + +;; line 323 "idxrule.nw" +(defclass relation () + ((rel-sets :accessor get-rel-sets + :initform '() ) + (rel-hash :accessor get-rel-hash + :initform (make-hash-table :test #'equal)))) + +(defun make-relation () + (make-instance 'relation)) +;; line 344 "idxrule.nw" +(defmethod rel-insert ((rel relation) x y) + (let* ((rel-sets (get-rel-sets rel)) + (x-node (assoc x rel-sets)) + (y-node (assoc y rel-sets))) + (cond ((null x-node) (setf (get-rel-sets rel) (cons (list x y) rel-sets))) + ((member y (cdr x-node))) + (t (rplacd x-node (cons y (cdr x-node))))) + (when (and (null y-node) (not (eql x y))) + (setf (get-rel-sets rel) (cons (list y) (get-rel-sets rel))))) + rel) + +(defmethod rel-simple-insert ((rel relation) x) + (let* ((rel-sets (get-rel-sets rel)) + (x-node (assoc x rel-sets))) + (unless x-node (setf (get-rel-sets rel) (cons (list x) rel-sets)))) + rel) +;; line 366 "idxrule.nw" +(defmethod rel-merge ((rel-1 relation) x) + (declare (ignore x)) + rel-1) + +(defmethod rel-merge ((rel-1 relation) (rel-2 relation)) + (mapc #'(lambda (r-2) + (let ((r-1 (assoc (car r-2) (get-rel-sets rel-1)))) + (cond ((null r-1) + (setf (get-rel-sets rel-1) + (cons r-2 (get-rel-sets rel-1)))) + (t (rplacd r-1 (union (cdr r-1) (cdr r-2))))))) + (get-rel-sets rel-2)) + rel-1) +;; line 387 "idxrule.nw" +(defmacro relation-set (rel x) + `(CDR (ASSOC ,x (SLOT-VALUE ,rel 'REL-SETS)))) +;; line 408 "idxrule.nw" +(defmethod make-ready ((rel relation)) + (let ((ht (get-rel-hash rel))) + (mapc #'(lambda (node) + (mapc #'(lambda (succ-node) + (setf (gethash (cons (car node) succ-node) ht) + t)) + (cdr node))) + (get-rel-sets rel))) + rel) +;; line 423 "idxrule.nw" +(defmacro relation-p (rel x y) + `(GETHASH (CONS ,x ,y) (SLOT-VALUE ,rel 'REL-HASH))) +;; line 439 "idxrule.nw" +(defun print-relation (rel-sets stream printfunc + &key open close headsep listsep) + (mapc #'(lambda (from) + (when open (format stream open)) + (write (funcall printfunc (car from)) :stream stream) + (when headsep (format stream headsep)) + (mapc #'(lambda (to) + (write (funcall printfunc to) :stream stream) + (when listsep (format stream listsep))) + (cdr from)) + (when close (format stream close))) + rel-sets)) +;; line 467 "idxrule.nw" +(defmethod topsort ((rel relation)) + (let ((rel-set (copy-tree (get-rel-sets rel))) + (topsort-list '())) + (loop + (let ((zero-indeg (find-if #'(lambda (x) (null (cdr x))) rel-set))) + (when (null zero-indeg) (return)) + (let ((zero-indeg-elt (car zero-indeg))) + (setq topsort-list (cons zero-indeg-elt topsort-list)) + (setq rel-set (delete zero-indeg rel-set :test #'equal)) + (mapc #'(lambda (x) + (rplacd x (delete zero-indeg-elt (cdr x) :test #'equal))) + rel-set))) + ) + (if (null rel-set) + (values topsort-list t) + (values nil rel-set)))) +;; line 494 "idxrule.nw" +(defmethod transform-relation ((rel relation) transform-func) + (let ((new-rel (make-relation))) + (mapc #'(lambda (x) + (let ((transformed-x (funcall transform-func (car x)))) + (mapc #'(lambda (y) + (rel-insert new-rel + transformed-x + (funcall transform-func y))) + (cdr x)))) + (get-rel-sets rel)) + new-rel)) +;; line 511 "idxrule.nw" +(defmethod remove-reflexivity ((rel relation)) + (mapc #'(lambda (x) + (rplacd x (delete (car x) (cdr x) :test #'equal))) + (get-rel-sets rel)) + rel) +;; line 529 "idxrule.nw" +(defmethod transitive-hull ((rel relation)) + (setf (get-rel-sets rel) + (let ((rel-sets (get-rel-sets rel))) + (mapc #'(lambda (j) + (mapc #'(lambda (i) + (when (member (car j) (cdr i)) + (mapc #'(lambda (k) + (when (and + (member (car k) (cdr j)) + (not (member (car k) + (cdr i)))) + (rplacd (last i) + (list (car k))))) + rel-sets))) + rel-sets)) + rel-sets))) + rel) +;; line 61 "idxrule.nw" +(defclass index-rule () + ()) + +(defclass relation-rule (index-rule relation) + ()) +;; line 88 "idxrule.nw" +(defclass merge-rule (relation-rule) + ()) + +(defun make-merge-rule () + (make-instance 'merge-rule)) +;; line 117 "idxrule.nw" +(defclass drop-if-merged-rule (relation-rule) + ()) + +(defun make-drop-if-merged-rule () + (make-instance 'drop-if-merged-rule)) +;; line 278 "idxrule.nw" +(defclass substitution-rule (relation-rule) + ()) + +(defun make-substitution-rule () + (make-instance 'substitution-rule)) +;; line 164 "idxrule.nw" +(defclass catattr-groups (index-rule) + ((attribute-list :reader get-attribute-list + :writer set-attribute-list + :initform nil) + (attribute-table :reader get-attribute-table + :initform (make-hash-table :test #'equal + :size 16)))) + +(defun make-catattr-groups () + (make-instance 'catattr-groups)) + +(defmethod add ((catattr-grp catattr-groups) + (catattr category-attribute)) + (setf (gethash (get-name catattr) (get-attribute-table catattr-grp)) + catattr)) + +(defmacro lookup-catattr-name (catattr-grp catattr-name) + `(GETHASH ,catattr-name (SLOT-VALUE ,catattr-grp 'ATTRIBUTE-TABLE))) +;; line 217 "idxrule.nw" +(defun initialize-category-attributes (attribute-list idxcls) + (let ((catattr-grps (get-cat-attrs idxcls)) + (impl-subst-rule (get-implicit-subst-rules idxcls))) + (set-attribute-list attribute-list catattr-grps) + (let ((catattr-grp-counter 0) + (sort-ordnum-counter 0)) + (mapc + #'(lambda (sublist) + (incf catattr-grp-counter) + (let ((last-in-group (lookup-catattr-name catattr-grps + (car (last sublist)))) + (prev-catattr nil)) + (mapc + #'(lambda (catattr) + (cond ((stringp catattr) + (let ((ca (lookup-catattr-name catattr-grps + catattr))) + (incf sort-ordnum-counter) + (set-sort-ordnum sort-ordnum-counter ca) + (set-catattr-grp-ordnum catattr-grp-counter ca) + (set-last-in-group last-in-group ca) + (when prev-catattr + (rel-insert impl-subst-rule + (lookup-catattr-name catattr-grps + prev-catattr) + (lookup-catattr-name catattr-grps + catattr))) + (setq prev-catattr catattr))) + (t (error "~A is not a string" catattr)))) + sublist))) + attribute-list)) + catattr-grps)) + +;; line 566 "idxrule.nw" +(eval-when (compile load eval) + +;; line 69 "idxrule.nw" +(export '(index-rule relation-rule)) +;; line 96 "idxrule.nw" +(export '(merge-rule make-merge-rule)) +;; line 125 "idxrule.nw" +(export '(drop-if-merged-rule make-drop-if-merged-rule)) +;; line 185 "idxrule.nw" +(export '(catattr-groups make-catattr-groups lookup-catattr-name)) +;; line 252 "idxrule.nw" +(export '(initialize-category-attributes catattr-single catattr-mixed)) +;; line 286 "idxrule.nw" +(export '(substitution-rule make-substitution-rule)) +;; line 428 "idxrule.nw" +(export '(relation make-relation get-rel-sets + rel-insert rel-merge make-ready + relation-set relation-p)) +;; line 549 "idxrule.nw" +(export '(topsort transform-relation remove-reflexivity transitive-hull)) +;; line 568 "idxrule.nw" + ) +;; line 873 "idxclass.nw" +;; $Id: idxclass.nw,v 1.20 1997/03/26 16:18:16 kehr Exp $ +;; + +;; line 129 "idxclass.nw" +(defparameter *locref-cache-size* 1000) +(defparameter *locref-cache-rehash-size* 2) +(defparameter *locref-cache-hits* 0) +(defparameter *locref-cache-misses* 0) +;; line 80 "idxclass.nw" +(defclass indexclass () + ((name :initarg :name :type string) + (basetypes :accessor get-basetypes + :initform (make-hash-table :test #'equal :size 10)) + (cat-attrs :accessor get-cat-attrs + :initform (make-catattr-groups)) + (locref-classes :accessor get-locref-classes + :initform '() :type list) + (xref-classes :accessor get-xref-classes + :initform '() :type list) + (letter-groups :reader get-letter-groups + :initform (make-letter-group-manager)) + (partial-order-dict :reader get-partial-order-dict + :initform (make-partial-order-dict)) + (letter-dict :reader get-letter-dict + :initform (make-letter-dict)) + (rule-sets :reader get-rule-sets + :initform (make-hash-table :test #'equal :size 20)) + +;; line 136 "idxclass.nw" + (locref-cache :initform (initialize-locref-cache)) +;; line 99 "idxclass.nw" + ;; (succ-table :accessor get-succ-table + ;; :initform (make-hash-table)) + +;; line 219 "idxclass.nw" + (merge-rules :reader get-merge-rules + :initform (make-merge-rule)) + (drop-if-merged-rules :reader get-drop-if-merged-rules + :initform (make-drop-if-merged-rule)) +;; (merge-rule-topsort :reader get-merge-rule-topsort +;; :writer set-merge-rule-topsort +;; :initform '()) + + +;; line 724 "idxclass.nw" + (merge-drop-hook :reader get-merge-drop-hook + :writer set-merge-drop-hook + :initform #'set-state-deleted) + +;; line 229 "idxclass.nw" + (implicit-subst-rules :reader get-implicit-subst-rules + :initform (make-substitution-rule)) + (explicit-subst-rules :reader get-explicit-subst-rules + :writer set-explicit-subst-rules + :initform (make-substitution-rule)) + +;; line 776 "idxclass.nw" + (implicit-subst-hook :reader get-implicit-subst-hook + :writer set-implicit-subst-hook + :initform #'transitive-hull) + (explicit-subst-hook :reader get-explicit-subst-hook + :writer set-explicit-subst-hook + :initform #'identity) + (global-subst-hook :reader get-global-subst-hook + :writer set-global-subst-hook + :initform #'identity) + (substitution-subst-hook :reader get-substitution-subst-hook + :writer set-substitution-subst-hook + :initform #'null) +;; line 102 "idxclass.nw" + )) + +(defun make-indexclass (name) + (make-instance 'indexclass :name name)) +;; line 253 "idxclass.nw" +(defparameter *default-letter-group-definition* "default") + +(defclass letter-group-definition () + ((name :initarg :name :type string) + (ordnum :initarg :ordnum :type number))) + +(defun make-letter-group-definition (name) + (make-instance 'letter-group-definition :name name :ordnum 0)) + +(defclass letter-group-manager () + ((prefixes :accessor get-prefixes + :initform (make-hash-table :test #'equal)) + (letter-groups :accessor get-letter-groups + :initform (make-hash-table :test #'equal)) + (sort-relation :accessor get-sort-relation + :initform (make-relation)) + (lookup-list :accessor get-lookup-list :initform '()))) + +(defun make-letter-group-manager () + (let* ((lgm (make-instance 'letter-group-manager)) + (letter-groups (get-letter-groups lgm)) + (default-group (make-letter-group-definition + *default-letter-group-definition*))) + (setf (gethash *default-letter-group-definition* letter-groups) + default-group) + (rel-simple-insert (get-sort-relation lgm) default-group) + lgm)) +;; line 295 "idxclass.nw" +(defun make-lookup-list (lgm) + (setf (get-lookup-list lgm) + (let ((lookup-list '())) + (maphash #'(lambda (key elt) + (push (cons key elt) lookup-list)) + (get-prefixes lgm)) + (sort lookup-list #'prefix<)))) + +(defun prefix< (x y) + (let ((cx (car x)) + (cy (car y))) + (let ((same-prefix (string/= cx cy))) + (cond ((null same-prefix)) + ((> same-prefix 0) + (and (= same-prefix (length (car y))))) + (t (string< cx cy)))))) +;; line 326 "idxclass.nw" +(defun add-letter-group-to-manager (lgm name prefix &key before after) + (let* ((prefixes (get-prefixes lgm)) + (letter-groups (get-letter-groups lgm)) + (letter-group (gethash name letter-groups))) + (unless letter-group;; this letter group is unknown -- create one! + (setq letter-group (make-letter-group-definition name)) + (setf (gethash name letter-groups) letter-group) + (rel-simple-insert (get-sort-relation lgm) letter-group)) + (let ((current-binding (gethash prefix prefixes))) + (and current-binding + (not (equal name (get-name current-binding))) + (warn "define-letter-group: prefix ~S now maps to letter group ~S" + prefix name))) + (setf (gethash prefix prefixes) letter-group) + (when before + (rel-insert (get-sort-relation lgm) + letter-group + (lookup-letter-group-definition *indexstyle* before))) + (when after + (rel-insert (get-sort-relation lgm) + (lookup-letter-group-definition *indexstyle* after) + letter-group))) + lgm) + +(defmethod lookup-letter-group-definition ((idxcls indexclass) (letter string)) + (gethash letter (get-letter-groups (get-letter-groups idxcls)))) +;; line 360 "idxclass.nw" +(defmethod make-ready ((lgm letter-group-manager)) + (make-lookup-list lgm) + (let ((sort-relation (get-sort-relation lgm))) + (multiple-value-bind (topsorted-list remaining-relation) + (topsort sort-relation) + (if topsorted-list + (let ((ctr 0)) + (mapc #'(lambda (grp-def) + (setf (get-ordnum grp-def) (incf ctr))) + topsorted-list)) + (error + (concatenate 'string + "The user-defined relations for the letter-groups contains cycles!~%The part of the relation containing cycles is" + (with-output-to-string (s) + (print-relation remaining-relation s + #'(lambda (lgdef) + (get-name lgdef)) + :open "~%" :headsep " before " + :listsep " ")))))))) +;; line 388 "idxclass.nw" +(defmethod match-letter-group ((idxcls indexclass) (letter string)) + (let* ((lgm (get-letter-groups idxcls)) + (lookup-list (get-lookup-list lgm)) + (match (find-if #'(lambda (prefix-cons) + (let* ((prefix (car prefix-cons)) + (match-len (string/= prefix letter))) + (or (not match-len) #| full match |# + (= match-len #| full match with lg |# + (length prefix))))) + lookup-list)) + (letter-group-definition + (if match + (cdr match);; the corresponding letter-grp-def + (lookup-letter-group-definition + *indexstyle* *default-letter-group-definition*)))) + (gol t "~&Letter-group: ~S -> ~S" + letter (get-name letter-group-definition)) + letter-group-definition)) +;; line 549 "idxclass.nw" +(defclass rule-set () + ((name :initarg :name) + (rules-list :accessor rules-list :initarg :rules-list) + (rules-hash :reader rules-hash + :initform (make-hash-table :test #'equal :size 32)) + )) + +(defun make-rule-set (name inherit rules) + (unless (every #'(lambda (rule) + (and (stringp (car rule));; pattern + (stringp (cadr rule)));; replacement + ) + rules) + (error "not a valid rule-set definition!")) + (let ((rs (make-instance 'rule-set :name name :rules-list rules))) + (let ((rh (rules-hash rs))) + (mapc #'(lambda (rule) + (setf (gethash (car rule) rh) rule)) + rules) + (mapc #'(lambda (inh-name) + (let ((inh-rs (lookup-rule-set *indexstyle* inh-name))) + (when inh-rs + (inherit-rule-set rs inh-rs)))) + inherit) + rs))) + +#| +(add-rule-set *indexstyle* + (make-rule-set "foo" '() '(("foo" "bar" :again) + ("baz" "bam" :string) + ("1" "3")))) + +(add-rule-set *indexstyle* + (make-rule-set "bar" '() '(("1" "bar" :again) + ("2" "bam" :string)))) +|# + +(defmacro instantiate-rule-set (run rule-set-names) + (let ((rs (make-rule-set "temporary rule-set" rule-set-names '()))) + (when rs + (cons 'progn + (mapcar #'(lambda (rule) + `(SORT-RULE ,@rule :RUN ,RUN)) + (rules-list rs)))))) + + + +(defun inherit-rule-set (rs parent) + (let ((rs-hash (rules-hash rs))) + (mapc #'(lambda (rule) + (let ((pattern (car rule))) + (unless (gethash pattern rs-hash) + (setf (gethash pattern rs-hash) rule) + (setf (rules-list rs) + (append (rules-list rs) (list rule)))))) + (rules-list parent)) + rs)) +;; line 140 "idxclass.nw" +(defun initialize-locref-cache () + (setq *locref-cache-hits* 0) + (setq *locref-cache-misses* 0) + (make-hash-table :test #'equal + :size *locref-cache-size* + :rehash-size *locref-cache-rehash-size*)) + +(defmethod clear-locref-cache ((idxclass indexclass)) + (setf (get-locref-cache idxclass) + (initialize-locref-cache))) + +(defun set-locref-cache-parameters (&key (size 1000) (rehash-size 3)) + (when (< size 100) (setq size 100)) + (when (< rehash-size 1.5) (setq rehash-size 1.5)) + (setq *locref-cache-size* size) + (setq *locref-cache-rehash-size* rehash-size)) +;; line 165 "idxclass.nw" +(defmacro lookup-locref-cache (idxcls locref-string) + `(LET ((LOCREF-LOOKUP (GETHASH ,locref-string + (SLOT-VALUE ,idxcls 'LOCREF-CACHE)))) + (IF LOCREF-LOOKUP + (PROGN + (INCF *LOCREF-CACHE-HITS*) + (VALUES (CAR LOCREF-LOOKUP) (CDR LOCREF-LOOKUP))) + (PROGN + (INCF *LOCREF-CACHE-MISSES*) + (VALUES NIL NIL))))) + +(defmethod add-locref-cache ((idxcls indexclass) + (locref-string string) + (num number) + ;; the next one is typeless, since we + ;; also want to store the value NIL into + ;; it, to denote a mismatch + locref) + (setf (gethash locref-string (get-locref-cache idxcls)) + (cons num locref)) + (values num locref)) + +(defmethod locref-statistics ((idxcls indexclass)) + (let ((ht (get-locref-cache idxcls))) + (with-output-to-string (s) + (format + s "Statistics for locref-cache of indexclass ~S:~%" (get-name idxcls)) + (format + s + "Hash-table: size=~A, count=~A, cache-hits=~A, cache-misses=~A, hits=~4,1,,'*F%~%" + (hash-table-size ht) (hash-table-count ht) + *locref-cache-hits* *locref-cache-misses* + (if (> *locref-cache-misses* 0) + (* 100 (/ *locref-cache-hits* (+ *locref-cache-hits* + *locref-cache-misses*))) + 100.0 #| produces an invalid value |#))))) +;; line 430 "idxclass.nw" +(defmethod add ((idxcls indexclass) (basetype basetype)) + (setf (gethash (get-name basetype) (get-basetypes idxcls)) + basetype) + idxcls) + +(defmethod add-alias ((idxcls indexclass) basetype alias-name) + (let ((new-basetype (make-copy (lookup-basetype idxcls basetype) + alias-name))) + (add idxcls new-basetype))) + +(defmethod add ((idxcls indexclass) (catattr category-attribute)) + (add (get-cat-attrs idxcls) catattr) + idxcls) +;; line 446 "idxclass.nw" +(defun add-letter-groups (idxcls name prefixes &key before after) + (let ((lgm (get-letter-groups idxcls))) + (mapc #'(lambda (prefix) + (add-letter-group-to-manager lgm name prefix + :before before + :after after)) + prefixes))) +;; line 462 "idxclass.nw" +(defmethod add ((idxcls indexclass) (loccls layered-location-class)) + (let* ((loccls-name (get-name loccls)) + (old-loccls (cdr (lookup-locref-class idxcls loccls-name)))) + (when old-loccls + (remove-location-class idxcls old-loccls)) + (if (get-locref-classes idxcls) #| if it is empty, we can't rplacd |# + (rplacd (last (get-locref-classes idxcls)) + (acons loccls-name loccls nil)) + (setf (get-locref-classes idxcls) + (acons loccls-name loccls nil)))) + idxcls) + +(defmethod remove-location-class ((idxcls indexclass) + (loccls layered-location-class)) + (setf (get-locref-classes idxcls) + (delete-if #'(lambda (elt) + (eq (cdr elt) loccls)) + (get-locref-classes idxcls))) + idxcls) +;; line 484 "idxclass.nw" +(defmethod add ((idxcls indexclass) (xrefcls crossref-location-class)) + (let ((xrefcls-name (get-name xrefcls))) + (setf (get-xref-classes idxcls) + (acons xrefcls-name xrefcls (get-xref-classes idxcls))) + idxcls)) +;; line 495 "idxclass.nw" +(defmethod add-merge-rule ((idxcls indexclass) + (catattr-1 category-attribute) + (catattr-2 category-attribute)) + (rel-insert (get-merge-rules idxcls) catattr-1 catattr-2) + idxcls) + +(defmethod add-drop-if-merged-rule ((idxcls indexclass) + (catattr-1 category-attribute) + (catattr-2 category-attribute)) + (rel-insert (get-merge-rules idxcls) catattr-1 catattr-2) + (rel-insert (get-drop-if-merged-rules idxcls) catattr-1 catattr-2) + idxcls) +;; line 512 "idxclass.nw" +(defmethod add-implicit-substitution-rule ( + (idxcls indexclass) + (catattr-1 category-attribute) + (catattr-2 category-attribute)) + (rel-insert (get-implicit-subst-rules idxcls) catattr-1 catattr-2) + idxcls) + + +(defmethod add-explicit-substitution-rule ( + (idxcls indexclass) + (catattr-1 category-attribute) + (catattr-2 category-attribute)) + (rel-insert (get-explicit-subst-rules idxcls) catattr-1 catattr-2) + idxcls) +;; line 609 "idxclass.nw" +(defmethod add-rule-set ((idxcls indexclass) (rs rule-set)) + (let ((rule-sets (get-rule-sets idxcls)) + (rs-name (get-name rs))) + (setf (gethash rs-name rule-sets) rs))) +;; line 635 "idxclass.nw" +(defmethod lookup-basetype ((idxcls indexclass) (basetype-name string)) + (gethash basetype-name (get-basetypes idxcls))) + +(defmethod lookup-catattr ((idxcls indexclass) (catattr-name string)) + (lookup-catattr-name (slot-value idxcls 'cat-attrs) catattr-name)) + +(defmethod lookup-location-class ((idxcls indexclass) (loccls-name string)) + (or (lookup-crossref-class idxcls loccls-name) + (lookup-locref-class idxcls loccls-name))) + +(defmethod lookup-crossref-class ((idxcls indexclass) (xref-name string)) + (assoc xref-name (slot-value idxcls 'xref-classes) :test #'equal)) + +(defmethod lookup-locref-class ((idxcls indexclass) (loccls-name string)) + (assoc loccls-name (slot-value idxcls 'locref-classes) :test #'equal)) + +(defmethod lookup-rule-set ((idxcls indexclass) (rule-set-name string)) + (gethash rule-set-name (get-rule-sets idxcls))) +;; line 685 "idxclass.nw" +(defmacro map-location-classes (idxcls apply-func &rest arguments) + `(LET () + (APPLY #'NCONC + (MAPCAR + #'(LAMBDA (ELT) + (LET ((RES + (FUNCALL ,apply-func + ,idxcls + (CDR ELT) #|ELT is ("name".<LOCATION-CLASS>))|# + ,@arguments))) + (WHEN RES (LIST RES)))) + (GET-LOCREF-CLASSES ,idxcls))))) + +;; line 800 "idxclass.nw" +(defmethod apply-substitution-hooks ((idxcls indexclass)) + (let ((impl (get-implicit-subst-rules idxcls)) + (expl (get-explicit-subst-rules idxcls))) + (funcall (get-implicit-subst-hook idxcls) impl) + (funcall (get-explicit-subst-hook idxcls) expl) + (rel-merge impl expl) + (set-explicit-subst-rules nil idxcls) + (funcall (get-global-subst-hook idxcls) impl) + (make-ready impl) + )) +;; line 838 "idxclass.nw" +(defmethod make-ready ((idxcls indexclass)) + (apply-substitution-hooks idxcls) + (make-ready (get-merge-rules idxcls)) + (make-ready (get-drop-if-merged-rules idxcls)) + (make-ready (get-letter-groups idxcls)) + + +;; (set-merge-rule-topsort (topsort +;; (remove-reflexivity +;; (transform-relation +;; (get-drop-if-merged-rules idxcls) +;; #'(lambda (attr) +;; (get-ordnum attr))))) +;; *indexstyle*) + + ;;(pprint (get-drop-if-merged-rules idxcls)) + ;;(pprint (topsort (get-drop-if-merged-rules idxcls))) + + (let ((counter 0)) + (mapc #'(lambda (catattr) + (set-processing-ordnum (incf counter) catattr)) + (reverse (topsort (get-drop-if-merged-rules idxcls))))) + + idxcls) + +;; line 888 "idxclass.nw" +(eval-when (compile load eval) + +;; line 109 "idxclass.nw" +(export '(indexclass make-indexclass + get-name get-basetypes + get-cat-attrs get-xref-classes + get-succ-table get-locref-classes + get-rule-sets + +;; line 241 "idxclass.nw" + get-merge-rules + get-drop-if-merged-rules +; get-merge-rule-topsort set-merge-rule-topsort + get-implicit-subst-rules set-implicit-subst-rules + get-explicit-subst-rules set-explicit-subst-rules +;; line 115 "idxclass.nw" + )) +;; line 204 "idxclass.nw" +(export '(locref-cache-size* *locref-cache-rehash-size* + initialize-locref-cache clear-locref-cache + lookup-locref-cache add-locref-cache + locref-statistics)) +;; line 409 "idxclass.nw" +(export '(letter-group-definition match-letter-group)) +;; line 530 "idxclass.nw" +(export '(add set + add-letter-groups + add-merge-rule + add-drop-if-merged-rule + add-implict-substitution-rule + add-explicit-substitution-rule)) +;; line 616 "idxclass.nw" +(export '(rule-set + make-rule-set + add-rule-set + instantiate-rule-set + inherit-rule-set)) +;; line 656 "idxclass.nw" +(export '(lookup-basetype + lookup-catattr + lookup-letter-group-definition + lookup-location-class + lookup-crossref-class + lookup-locref-class + lookup-rule-set)) +;; line 700 "idxclass.nw" +(export 'map-location-classes) +;; line 730 "idxclass.nw" +(export '(get-merge-drop-hook set-merge-drop-hook)) +;; line 791 "idxclass.nw" +(export '(get-implicit-subst-hook set-implicit-subst-hook + get-explicit-subst-hook set-explicit-subst-hook + get-global-subst-hook set-global-subst-hook + get-substitution-subst-hook set-substitution-subst-hook)) +;; line 823 "idxclass.nw" +(export '(apply-substitution-hooks)) +;; line 865 "idxclass.nw" +(export '(make-ready)) +;; line 890 "idxclass.nw" + ) +;; line 54 "idxstyle.nw" +(defun create-indexclass (idxcls-name) + (setq *indexstyle* (make-indexclass idxcls-name))) +;; line 259 "letters.nw" +;; $Id$ + +;; line 37 "letters.nw" +(defclass letter () + ((name :initarg :name :type string) + (props :initarg :props :type list))) + +(defun make-letter (name properties inherits-from) + (make-instance 'letter + :name name + :props (if inherits-from + (append properties (get-props inherits-from)) + properties))) + +(defun find-prop (letter prop) + (assoc prop (get-props letter))) +;; line 53 "letters.nw" +(defclass letter-dictionary () + ((letters :initform (make-hash-table :test #'equal)))) + +(defun make-letter-dict () + (make-instance 'letter-dictionary)) + +(defun find-letter* (dict-ht letter) + (gethash letter dict-ht)) + +(defun find-letter (dict letter) + (gethash letter (get-letters dict))) + +(defun add-letter-to-dict (letter-dict + po-dict + name props + &optional + inherits) + (let ((dict-ht (get-letters letter-dict))) + (when (gethash name dict-ht) + (nraw "Letter `~S' redefined!" name)) + (setf (gethash name dict-ht) + (make-letter name + (pre-calculate-props props po-dict) + (when inherits + (find-letter* dict-ht name)))))) +;; line 85 "letters.nw" +(defun pre-calculate-props (props po-dict) + (mapc #'(lambda (po-spec) + (let ((po-name (car po-spec)) + (po-val (cadr po-spec))) + (setf (cdr (last po-spec)) + (list (find-prop-weight + (find-partial-order po-dict po-name) + po-val))))) + props) + props) +;; line 98 "letters.nw" +(defmacro define-letter (&whole whole &rest rest) + (destructuring-switch-bind (name &rest proplist) + rest + (cond +;; line 239 "intface.nw" +((null name) + (error "missing argument <name> in `~S' !" whole)) +((not (or (symbolp name) (stringp name))) + (error "~S is not a symbol or a string in `~S' !" name whole)) +;; line 102 "letters.nw" + ((not (listp proplist)) + (error "~S is not a property list in ~S." proplist whole)) + (t `(LET ((NAME (STRINGIFY ',name))) + (ADD-LETTER-TO-DICT + (GET-LETTER-DICT *INDEXSTYLE*) + (GET-PARTIAL-ORDER-DICT *INDEXSTYLE*) + ,name ',proplist)))))) +;; line 119 "letters.nw" +(defclass partial-order () + ((name :initarg :name :type string) + (order :initform (make-hash-table :test #'equal)) + (direct :initarg :direct :type symbol))) + +(defun make-partial-order (name order &optional (direct :from-start)) + (let* ((po (make-instance 'partial-order :name name :direct direct)) + (po-ht (get-order po)) + (ctr 0)) + (mapc #'(lambda (elt) + (when (gethash elt po-ht) + (error "Element ~S doubly defined in partial order ~S." + elt name)) + (setf (gethash elt po-ht) (incf ctr))) + order) + po)) +;; line 140 "letters.nw" +(defclass partial-order-dictionary () + ((order :initform (make-hash-table :test #'equal)))) + +(defun make-partial-order-dict () + (make-instance 'partial-order-dictionary)) + +(defun find-partial-order (dict po-name) + (gethash po-name (get-order dict))) + +(defun find-prop-weight (po po-name) + (gethash po-name (get-order po))) + +(defun add-partial-order-to-dict (dict po-name po-order po-direct) + (let ((dict-ht (get-order dict))) + (when (gethash po-name dict-ht) + (nraw "Partial order ~S redefined!" po-name)) + (setf (gethash po-name dict-ht) + (make-partial-order po-name po-order po-direct)))) +;; line 161 "letters.nw" +(defmacro define-partial-order (&whole whole &rest rest) + (destructuring-switch-bind (name + ordlist + &switch + from-start + from-end) + rest + (cond +;; line 239 "intface.nw" +((null name) + (error "missing argument <name> in `~S' !" whole)) +((not (or (symbolp name) (stringp name))) + (error "~S is not a symbol or a string in `~S' !" name whole)) +;; line 169 "letters.nw" + ((not (listp ordlist)) + (error "~S is not a partial order list in ~S." ordlist whole)) + ((and from-start from-end) + (error "Only one of :from-start or :from-end is allowed in ~S." + whole)) + (t `(LET ((NAME (STRINGIFY ',name))) + (ADD-PARTIAL-ORDER-TO-DICT + (GET-PARTIAL-ORDER-DICT *INDEXSTYLE*) + ,name ',ordlist + ,(if (or from-start (not from-end)) + :from-start :from-end))))))) +;; line 194 "letters.nw" +(defun word-cmp (word1 word2 po) + (let ((po-name (get-name po)) + let1 let2 weight1 weight2) + (loop + (cond + ((and (endp word1) (endp word2)) (return :equal)) + ((endp word1) (return :less)) + ((endp word2) (return :greater)) + (t (setq let1 (car word1)) + (setq word1 (cdr word1)) + (setq let2 (car word2)) + (setq word2 (cdr word2)) + (setq weight1 (lookup-letter-weight let1 po-name)) + (setq weight2 (lookup-letter-weight let2 po-name)) + (when (< weight1 weight2) (return :less)) + (when (> weight1 weight2) (return :greater))))))) + +(defun calc-list-of-weights (word po) + (let ((po-name (get-name po))) + (mapcar #'(lambda (letter) + (lookup-letter-weight letter po-name)) + word))) +;; line 227 "letters.nw" +(defun lookup-letter-weight (letter po-name) + (let ((prop (find-prop letter po-name))) + (if prop + (car (last prop)) + (find-prop-weight + (find-partial-order (get-partial-order-dict *indexstyle*) po-name) + 'others)))) +;; line 237 "letters.nw" +(defun make-word (letter-list) + (let ((dict (get-letter-dict *indexstyle*))) + (mapcar #'(lambda (str) + (find-letter dict str)) + letter-list))) + +(defun sort-words (word-list po) + (split-list #'(lambda (word) + (calc-list-of-weights word po)) + word-list)) + + + +;; line 99 "idxstyle.nw" +(create-indexclass "default") +;; line 107 "idxstyle.nw" +(defmacro string-expand (str) + (let ((str-expansion + (map 'list + #'(lambda (c) + (make-string 1 :initial-element c)) + str))) + `(QUOTE ,str-expansion))) + +(define-alphabet* "ALPHA" (string-expand "ABCDEFGHIJKLMNOPQRSTUVWXYZ")) +(define-alphabet* "alpha" (string-expand "abcdefghijklmnopqrstuvwxyz")) +(define-alphabet* "digits" (string-expand "0123456789")) +;; line 128 "idxstyle.nw" +(defun prefix-match-for-radix-numbers (str radix) + (let* ((n nil) + (strlen (length str)) + (len-match (do ((i 0 (1+ i))) + ((or (>= i strlen) + (not (digit-char-p (char str i) radix))) + i) + (setq n (+ (* (if n n 0) radix) + (digit-char-p (char str i) radix)))))) + (values (subseq str 0 len-match) + (subseq str len-match) + n))) +;; line 155 "idxstyle.nw" +(define-enumeration "arabic-numbers" + #'(lambda (str) + (prefix-match-for-radix-numbers str 10)) + "0123456789") +;; line 178 "idxstyle.nw" +(defparameter *lowercase-roman-numbers-lookup-table* + '((#\i ("ix" . 9) ("iv" . 4) ("iiii" . 4) ("iii". 3) ("ii" . 2) ("i" . 1)) + (#\v ("viiii" . 9) ("viii" . 8) ("vii" . 7) ("vi" . 6) ("v" . 5)) + (#\x ("xc" . 90) ("xl" . 40) ("x" . 10)) + (#\m ("m" . 1000)) + (#\c ("cm" . 900) ("cd" . 400) ("c" . 100)) + (#\l ("lxxxx" . 90) ("lxxx" . 80) ("lxx" . 70) ("lx" . 60) ("l" . 50)) + (#\d ("dcccc" . 900) ("dccc" . 800) ("dcc" . 700) ("dc" . 600) ("d" . 500)) + )) + +(defparameter *uppercase-roman-numbers-lookup-table* + '((#\I ("IX" . 9) ("IV" . 4) ("IIII" . 4) ("III". 3) ("II" . 2) ("I" . 1)) + (#\V ("VIIII" . 9) ("VIII" . 8) ("VII" . 7) ("VI" . 6) ("V" . 5)) + (#\X ("XC" . 90) ("XL" . 40) ("X" . 10)) + (#\M ("M" . 1000)) + (#\C ("CM" . 900) ("CD" . 400) ("C" . 100)) + (#\L ("LXXXX" . 90) ("LXXX" . 80) ("LXX" . 70) ("LX" . 60) ("L" . 50)) + (#\D ("DCCCC" . 900) ("DCCC" . 800) ("DCC" . 700) ("DC" . 600) ("D" . 500)) + )) +;; line 206 "idxstyle.nw" +(defun roman-number-prefix-match (roman-number-string *table*) + (let ((result 0) + (str roman-number-string) + (last-val 100000) #| hope that's enough |# + (str-len (length roman-number-string)) + ch table match-cons curr-val + ) + (loop (when (= 0 (length str)) + (return (values roman-number-string "" result))) + (setq ch (aref str 0)) + (setq table (cdr (assoc ch *table*))) + (setq match-cons + (find-if #'(lambda (cons) + (let* ((prefix (car cons)) + (match-len (string/= prefix str))) + (or (not match-len) + (= match-len (length prefix))))) + table)) + (unless match-cons + (return (if (= 0 result) + (values nil nil nil) + (values (subseq roman-number-string + 0 (- str-len (length str))) + str result)))) + (setq curr-val (cdr match-cons)) + (when (> curr-val last-val) + (return (values (subseq roman-number-string + 0 (- str-len (length str))) + str result))) + (incf result curr-val) + (setq last-val curr-val) + (setq str (subseq str (length (car match-cons))))))) +;; line 241 "idxstyle.nw" +(define-enumeration "roman-numbers-uppercase" + #'(lambda (str) + (roman-number-prefix-match + str + *uppercase-roman-numbers-lookup-table*)) + "IVXLCDM") + +(add-alias *indexstyle* "roman-numbers-uppercase" "ROMAN") +(add-alias *indexstyle* "roman-numbers-uppercase" "roman-numerals-uppercase") + +(define-enumeration "roman-numbers-lowercase" + #'(lambda (str) + (roman-number-prefix-match + str + *lowercase-roman-numbers-lookup-table*)) + "ivxlcdm") + +(add-alias *indexstyle* "roman-numbers-lowercase" "roman") +(add-alias *indexstyle* "roman-numbers-lowercase" "roman-numerals-lowercase") + + +;; line 902 "idxclass.nw" +#+:XP +(defmacro pprint-slot-block (slot-name body) + `(progn + (pprint-logical-block (s nil :suffix " }") + (pprint-indent :block 2 s) + (write-string ,slot-name s) + (pprint-newline :mandatory s) + ,body) + (pprint-newline :mandatory s))) + +#+:XP +(defmacro pprint-slot-block-line (slot-name body) + `(progn + (pprint-logical-block (s nil :suffix " }") + (pprint-indent :block 2 s) + (write-string ,slot-name s) + (pprint-newline :linear s) + ,body) + (pprint-newline :mandatory s))) +;; line 924 "idxclass.nw" +#+:XP +(set-pprint-dispatch 'indexclass + #'(lambda (s idxcls) + (pprint-logical-block + (s nil :suffix "}") + (pprint-indent :block 2 s) + (write-string "indexclass " s) + (write (get-name idxcls) :stream s) + (write-string " {" s) + (pprint-newline :mandatory s) + (pprint-slot-block + "basetypes {" + (maphash #'(lambda (key bt) + (declare (ignore key)) + (write (get-name bt) :stream s) + (write-string " " s) + (pprint-newline :linear s)) + (get-basetypes idxcls))) + (pprint-slot-block + "cat-attrs {" + (write (get-cat-attrs idxcls) :stream s)) + (pprint-slot-block + "locclasses {" + (mapc #'(lambda (lc) + (write (get-name (cdr lc)) :stream s) + (write-string " [" s) + (write (get-ordnum (cdr lc)) :stream s) + (write-string "] " s) + (pprint-newline :linear s)) + (get-locref-classes idxcls))) + (pprint-slot-block + "xrefclasses {" + (mapc #'(lambda (lc) + (write (get-name (cdr lc)) :stream s) + (write-string " [" s) + (write (get-ordnum (cdr lc)) :stream s) + (write-string "] " s) + (pprint-newline :linear s)) + (get-xref-classes idxcls))) + + (write (get-letter-dict idxcls) :stream s) + (pprint-newline :mandatory s) + (write (get-partial-order-dict idxcls) :stream s) + (pprint-newline :mandatory s) + + (pprint-slot-block + "merge-rules {" + (write (get-merge-rules idxcls) :stream s)) + (pprint-slot-block + "drop-if-merged-rules {" + (write (get-drop-if-merged-rules idxcls) :stream s)) + ;; (pprint-slot-block-line + ;; "merge-rule-topsort { " + ;; (write (get-merge-rule-topsort idxcls) :stream s)) + (pprint-slot-block + "implicit-subst-rules {" + (write (get-implicit-subst-rules idxcls) :stream s)) + (pprint-slot-block + "explicit-subst-rules {" + (write (get-explicit-subst-rules idxcls) :stream s)) + + (pprint-slot-block-line + "implicit-subst-hook {" + (write (get-implicit-subst-hook idxcls) :stream s)) + (pprint-slot-block-line + "explicit-subst-hook {" + (write (get-explicit-subst-hook idxcls) :stream s)) + (pprint-slot-block-line + "global-subst-hook {" + (write (get-global-subst-hook idxcls) :stream s)) + (pprint-slot-block-line + "substitution-subst-hook {" + (write (get-substitution-subst-hook idxcls) :stream s)) + (pprint-slot-block-line + "merge-drop-hook {" + (write (get-merge-drop-hook idxcls) :stream s)) + + ; (pprint-slot-block + ; "keyword-markup {" + ; (write (get-keyword-markup idxcls) :stream s)) + ))) +;; line 580 "idxrule.nw" +#+:XP +(defun pprint-relation (s rel) + (pprint-logical-block + (s nil :suffix "}") + (pprint-indent :block 2 s) + (write-string "Relation { " s) + (pprint-logical-block (s nil) + (pprint-indent :block 2) + (mapc #'(lambda (x) + (when x + (write (car x) :stream s) + (write-string " ->" s) + (mapc #'(lambda (y) + (write-string " " s) + (write y :stream s)) + (cdr x)) + (pprint-newline :mandatory s))) + (get-rel-sets rel))))) + +#+:XP +(set-pprint-dispatch 'relation-rule #'pprint-relation) +#+:XP +(set-pprint-dispatch 'relation #'pprint-relation) +;; line 606 "idxrule.nw" +#+:XP +(set-pprint-dispatch + 'catattr-groups + #'(lambda (s catgrp) + (pprint-logical-block + (s nil :suffix "}") + (pprint-indent :block 2 s) + (write-string "Category-attribute-group { " s) + (pprint-newline :mandatory s) + (write (get-attribute-list catgrp) :stream s) + (pprint-newline :mandatory s) + (write (get-attribute-table catgrp) :stream s)))) +;; line 277 "letters.nw" +#+:XP +(set-pprint-dispatch 'letter + #'(lambda (s lt) + (pprint-logical-block + (s nil :suffix ">") + (pprint-indent :block 2 s) + (write-string "<" s) + (write (get-name lt) :stream s) + (write-string " " s) + (pprint-newline :linear s) + (write (get-props lt) :stream s)))) + +#+:XP +(set-pprint-dispatch 'letter-dictionary + #'(lambda (s dict) + (pprint-logical-block + (s nil :suffix "}") + (pprint-indent :block 2 s) + (write-string "letters {" s) + (maphash #'(lambda (key lt) + (declare (ignore key)) + (write lt :stream s) + (write-string " " s) + (pprint-newline :linear s)) + (get-letters dict))))) + +#+:XP +(set-pprint-dispatch 'partial-order + #'(lambda (s po) + (pprint-logical-block + (s nil :suffix ">") + (pprint-indent :block 2 s) + (write-string "<" s) + (write (get-name po) :stream s) + (pprint-newline :linear s) + (maphash #'(lambda (key po) + (write-string " [" s) + (write key :stream s) + (write-string " " s) + (write po :stream s) + (write-string "]" s) + (pprint-newline :linear s)) + (get-order po))))) + + +#+:XP +(set-pprint-dispatch 'partial-order-dictionary + #'(lambda (s dict) + (pprint-logical-block + (s nil :suffix "}") + (pprint-indent :block 2 s) + (write-string "partial-orders {" s) + (maphash #'(lambda (key po) + (declare (ignore key)) + (write po :stream s) + (write-string " " s) + (pprint-newline :linear s)) + (get-order dict))))) + +;; line 321 "idxstyle.nw" +(defvar *RCS-Identifier* '( +;; line 894 "idxclass.nw" +("idxclass" . "$Id: idxclass.nw,v 1.20 1997/03/26 16:18:16 kehr Exp $") +;; line 572 "idxrule.nw" +("idxrule" . "$Id: idxrule.nw,v 1.10 1997/03/26 16:18:19 kehr Exp $") +;; line 335 "idxstyle.nw" +("idxstyle" . "$Id: idxstyle.nw,v 1.19 1997/03/26 16:18:23 kehr Exp $") +;; line 1174 "intface.nw" +("intface" . "$Id: intface.nw,v 1.30 1997/10/20 11:25:09 kehr Exp $") +;; line 269 "letters.nw" +("letters" . "$Id$") +;; line 321 "idxstyle.nw" + )) + +(eval-when (compile load eval) + +;; line 59 "idxstyle.nw" +(export 'create-indexclass) +;; line 89 "idxstyle.nw" +(export '*load-paths*) +;; line 325 "idxstyle.nw" + ) diff --git a/Build/source/utils/xindy/xindy-2.4/src/index.lsp b/Build/source/utils/xindy/xindy-2.4/src/index.lsp new file mode 100644 index 00000000000..7d171f96fab --- /dev/null +++ b/Build/source/utils/xindy/xindy-2.4/src/index.lsp @@ -0,0 +1,1333 @@ +;; line 835 "index.nw" +;; $Id: index.nw,v 1.31 1997/03/26 16:18:37 kehr Exp $ + +(lisp:defpackage "INDEX") +(lisp:in-package "INDEX") +(lisp:provide "index") + +#+CLISP (lisp:require "base") +#+CLISP (lisp:require "locref") +#+CLISP (lisp:require "idxstyle") +#+CLISP (lisp:require "ordrules") + +(eval-when (compile load eval) + (lisp:use-package "CLOS") + #+(and :XP CLISP) (lisp:use-package "XP") + #-CLISP (lisp:require "base") + #-CLISP (lisp:require "locref") + #-CLISP (lisp:require "idxstyle") + (lisp:use-package "BASE") + (lisp:use-package "LOCREF") + (lisp:use-package "IDXSTYLE")) + +;; The following construct must be separated since the definition of +;; the *feature* :ORDRULES was added via loading the package +;; "idxstyle" but is only active *after* reading the whole SEXP. + +(eval-when (compile load eval) + #+:ORDRULES (use-package "ORDRULES")) + +;; line 986 "idxentry.nw" +;; $Id: idxentry.nw,v 1.29 1997/03/27 17:17:25 kehr Exp $ + +;; line 1002 "idxentry.nw" +(defvar *number-of-indexentries*) +(defvar *current-number*) +;; line 1007 "idxentry.nw" +(defvar *percentage-list*) +(defvar *processing-percentage-list*) + +(defun print-rest-of-percentages (plist) + (dolist (percent plist) + (when (<= (cdr percent) 100) + (print-percent percent)))) + +(defun print-percent (percent-cons) + (info " [~A%]" (cdr percent-cons))) +;; line 85 "idxentry.nw" +(defclass index-entry () + ((main-key :initarg :main-key) + (merge-key :initarg :merge-key) + (sort-key :initarg :sort-key) + (print-key :initarg :print-key) + (locrefs :initarg :locrefs) + (idxclass :initarg :idxclass) + (subentries :initform '()))) + +(defun make-index-entry (&key (main-key '()) (merge-key '()) + (sort-key '()) (print-key '()) + (locrefs '()) (idxclass nil) + &allow-other-keys) + (make-instance 'index-entry + :main-key main-key :merge-key merge-key + :sort-key sort-key :print-key print-key + :locrefs locrefs :idxclass idxclass)) +;; line 108 "idxentry.nw" +(defvar *currently-processed-indexentry*) +;; line 116 "idxentry.nw" +(defmacro add-location-reference-to-indexentry (idxent locref) + `(PROGN + (UNLESS (SOME #'(LAMBDA (LREF) + (LOCREF= ,locref LREF)) + (GET-LOCREFS ,idxent)) + (SET-LOCREFS (CONS ,locref (GET-LOCREFS ,idxent)) + ,idxent)) + ,idxent)) +;; line 249 "idxentry.nw" +(defun convert-sublists-to-group-objects (list-of-sublists + object-type + &key (initializer-func nil)) + (mapcar #'(lambda (sublist) + (let ((locref-grp (make-locref-group object-type sublist))) + (if initializer-func + (funcall initializer-func locref-grp) + locref-grp))) + list-of-sublists)) +;; line 267 "idxentry.nw" +(defun convert-sublists-to-specialized-groups (list-of-sublists + convert-func + &optional + initializer-func) + (mapcar #'(lambda (sublist) + (let ((locref-grp + (make-locref-group (funcall convert-func sublist) + sublist))) + (if initializer-func + (funcall initializer-func locref-grp) + locref-grp))) + list-of-sublists)) +;; line 292 "idxentry.nw" +(defclass locref-group () + ((members :initarg :members))) + +(defun make-locref-group (group-class members) + (make-instance group-class :members members)) + +(defgeneric process-group (group-object indexclass)) +;; line 322 "idxentry.nw" +(defclass locref-class-group (locref-group) + ((locclass :initform 'nil))) +;; line 327 "idxentry.nw" +(defclass crossref-class-group (locref-group) + ((locclass :initform 'nil))) +;; line 333 "idxentry.nw" +(defun process-indexentry (idxent) + (setq *currently-processed-indexentry* idxent) + (when (>= (incf *current-number*) (caar *processing-percentage-list*)) + (print-percent (pop *processing-percentage-list*))) + (set-locrefs (convert-sublists-to-specialized-groups + (split-list #'(lambda (locref) + (get-ordnum (get-locclass locref))) + (get-locrefs idxent) + :sortfunc #'<) + #'(lambda (sublist) + (typecase (car sublist) + (layered-location-reference 'locref-class-group) + (crossref-location-reference 'crossref-class-group) + (t (error "internal error in `process-indexentry'")))) + #'(lambda (locref-cls-grp) + (set-locclass (get-locclass + (car (get-members locref-cls-grp))) + locref-cls-grp) + locref-cls-grp)) + idxent) + (mapc #'(lambda (locref-cls-grp) + (process-group locref-cls-grp *indexstyle*)) + (get-locrefs idxent)) + idxent) +;; line 899 "idxentry.nw" +(defmacro take-first (list) + `(AND ,list (LIST (CAR ,list)))) + +(defun tree-location-references (locref-list + max-depth + &optional (curr-depth 1)) + (cond ((or (endp locref-list) #| nothing more to do |# + (> curr-depth max-depth)) #| we reached the end |# + locref-list) + (t (let ((locref-slist + (split-list #'(lambda (locref) + (car (get-ordnums locref))) + locref-list + :sortfunc #'<))) + (mapcar + #'(lambda (sublist) + (let* ((locref (car sublist)) + (ordnums (get-ordnums locref))) + (if (= 1 (length ordnums)) + (progn #| length = 1 |# + (set-subrefs + (sort-locrefs + (tree-location-references (remove-first-layers + (cdr sublist)) + max-depth + (1+ curr-depth))) + locref) + locref) + (let #| length > 1 |# + ((new-locref + (make-layered-location-reference + :layers (take-first (get-layers locref)) + :ordnums (take-first (get-ordnums locref)) + :locclass (get-locclass locref) + :catattr (get-last-in-group + (get-catattr locref)) + ))) + (set-subrefs + (sort-locrefs + (tree-location-references (remove-first-layers sublist) + max-depth + (1+ curr-depth))) + new-locref) + new-locref)))) + locref-slist))))) +;; line 947 "idxentry.nw" +(defun remove-first-layers (locref-list) + (declare (inline)) + (mapc #'(lambda (locref) + (typecase locref + (layered-location-reference + (set-layers (cdr (get-layers locref)) locref) + (set-ordnums (cdr (get-ordnums locref)) locref)) + (location-range + (let ((first (get-first locref)) + (last (get-last locref))) + (set-layers (cdr (get-layers locref)) locref) + (set-ordnums (cdr (get-ordnums locref)) locref) + (set-layers (cdr (get-layers first)) first) + (set-ordnums (cdr (get-ordnums first)) first) + (set-layers (cdr (get-layers last)) last) + (set-ordnums (cdr (get-ordnums last)) last) + )))) + locref-list) + locref-list) +;; line 973 "idxentry.nw" +(defun sort-locrefs (locref-list) + #+:ASSERT! (assert! (listp locref-list)) + (sort locref-list + #'(lambda (locref-1 locref-2) + (locref-ordnum< (get-ordnums locref-1) + (get-ordnums locref-2))))) +;; line 370 "idxentry.nw" +(defmethod process-group ((locref-cls-grp locref-class-group) + (idxcls indexclass)) + #+:XP + (when *locref-trace* (pprint-locref-group *logging-stream* locref-cls-grp + "Inital location-refrence group:")) + (apply-substitution-and-merge-rules locref-cls-grp idxcls) + #+:XP + (when *locref-trace* (pprint-locref-group *logging-stream* locref-cls-grp + "After subst- and merge-to-rules:")) + (build-ranges-in-locref-class-group locref-cls-grp idxcls) + #+:XP + (when *locref-trace* (pprint-locref-group *logging-stream* locref-cls-grp + "After build-ranges:")) + (remove-virtual-locrefs locref-cls-grp) + #+:XP + (when *locref-trace* (pprint-locref-group *logging-stream* locref-cls-grp + "After remove virtuals:")) + (separate-into-catattr-groups locref-cls-grp) + #+:XP + (when *locref-trace* (pprint-locref-group *logging-stream* locref-cls-grp + "After separate attr-groups:")) + locref-cls-grp) + +;; line 531 "idxentry.nw" +(defmethod apply-substitution-and-merge-rules ((locref-cls-grp locref-class-group) + (idxcls indexclass)) + (let ((locref-same-ordnum-grps + (split-same-locrefs (get-members locref-cls-grp)))) + (set-members + (mapcan #'(lambda (locref-same-ordnum-grp) + (apply-merge-rules + idxcls + (apply-substitution-rules idxcls + locref-same-ordnum-grp))) + locref-same-ordnum-grps) + locref-cls-grp)) + locref-cls-grp) + +;; line 553 "idxentry.nw" +(defun split-same-locrefs (locrefs) + #+ASSERT! (assert! (listp locrefs)) + (split-list #'(lambda (locref) + (get-ordnums locref)) + locrefs + :sortfunc #'(lambda (locref-ordnum-1 locref-ordnum-2) + (locref-ordnum< locref-ordnum-1 locref-ordnum-2)) + )) +;; line 569 "idxentry.nw" +(defmethod apply-substitution-rules ((idxcls indexclass) + (locrefs list)) + (let ((substitute-locref (get-substitution-subst-hook idxcls))) + (delete-if #'null + (mapcar #'(lambda (test-locref) + (cond ((some #'(lambda (against-locref) + (substitutable-p idxcls test-locref + against-locref)) + locrefs) + (funcall substitute-locref test-locref)) + (t test-locref))) + locrefs)))) +;; line 590 "idxentry.nw" +(defmethod substitutable-p ((idxcls indexclass) + (test-locref layered-location-reference) + (against-locref layered-location-reference)) + (cond ((eql test-locref against-locref) + nil) + ((and (state-normal-p against-locref) + (relation-p (get-implicit-subst-rules idxcls) + (get-catattr against-locref) + (get-catattr test-locref)))) + (t nil))) +;; line 638 "idxentry.nw" +(defmethod apply-merge-rules ((idxcls indexclass) (locrefs list)) + (let ((merge-rules (get-merge-rules idxcls)) + (drop-if-merged-rules (get-drop-if-merged-rules idxcls))) + (nconc locrefs + (mapcan #'(lambda (locref) + (mapcan #'(lambda (catattr) + (let ((new-locref + (make-layered-location-reference + :virtual t + :layers (get-layers locref) + :ordnums (get-ordnums locref) + :catattr catattr + :locclass (get-locclass locref) + :attribute (get-attribute locref) + :string (get-locref-string locref) + ))) + (when (relation-p drop-if-merged-rules + (get-catattr locref) + catattr) + (set-origin locref new-locref)) + (list new-locref))) + (relation-set merge-rules (get-catattr locref)))) + locrefs)))) +;; line 721 "idxentry.nw" +(defun build-ranges-in-locref-class-group (locref-cls-grp idxcls) + (let ((locref-same-catattr-grps + (split-list #'(lambda (locref) (get-catattr locref)) + (get-members locref-cls-grp) + :sortfunc #'(lambda (x y) + (< (get-processing-ordnum x) + (get-processing-ordnum y)))))) + (set-members (mapcan #'(lambda (catattr-sublist) + (let ((processed-locrefs + (build-ranges catattr-sublist + idxcls + (get-locclass + (car catattr-sublist))))) + (when *locref-trace* + (let ((*print-pretty* t)) + (gol t "~&after build-ranges:") + (pprint-newline :mandatory *logging-stream*) + (pprint-newline :mandatory *logging-stream*) + (write processed-locrefs + :stream *logging-stream*))) + (let ((s2 (mapcar + #'(lambda (x) + (post-process + x + #'set-state-deleted)) + processed-locrefs))) + (when *locref-trace* + (let ((*print-pretty* t)) + (gol t "~&after set-state-deleted:") + (pprint-newline :mandatory *logging-stream*) + (pprint-newline :mandatory *logging-stream*) + (write s2 :stream *logging-stream*))) + s2))) + locref-same-catattr-grps) + locref-cls-grp))) +;; line 396 "idxentry.nw" +(defmethod process-group ((crossref-cls-grp crossref-class-group) + (idxcls indexclass)) + (let ((cross-references (get-members crossref-cls-grp))) + (typecase (get-locclass (car cross-references)) + (verified-crossref-location-class + (mapc #'(lambda (xref) + (let* ((target (get-target xref)) + (merge-key-target + #+:ORDRULES (gen-keyword-mergekey-list target) + #-:ORDRULES target)) + (unless (lookup-indexentry merge-key-target) + (oops "Cross-reference-target ~S does not exist!" + target)))) + cross-references)) + (unverified-crossref-location-class) + (t (error "INTERNAL ERROR in process-group")))) + crossref-cls-grp) +;; line 422 "idxentry.nw" +(defun remove-virtual-locrefs (locref-cls-grp) + (set-members (delete-if #'(lambda (object) + (and (typep object 'location-reference) + (state-virtual-p object))) + (get-members locref-cls-grp)) + locref-cls-grp)) +;; line 794 "idxentry.nw" +(defclass category-attribute-group (locref-group) + ((ordnum :initform 'nil))) + +(defun separate-into-catattr-groups (locref-cls-grp) + (set-members (convert-sublists-to-group-objects + (split-list #'(lambda (object) + (get-catattr-grp-ordnum (get-catattr object))) + (get-members locref-cls-grp) + :sortfunc #'<) + 'category-attribute-group) + locref-cls-grp) + (mapc #'(lambda (catattr-grp) + (set-ordnum (get-catattr-grp-ordnum + (get-catattr (car (get-members catattr-grp)))) + catattr-grp) + (set-members + (sort (tree-location-references (get-members catattr-grp) + (get-hierdepth + (get-locclass locref-cls-grp))) + #'(lambda (object-1 object-2) + (let ((ordnum-1 (get-ordnums object-1)) + (ordnum-2 (get-ordnums object-2))) + (or (locref-ordnum< ordnum-1 ordnum-2) + (and (locref-ordnum= ordnum-1 ordnum-2) + (< (get-sort-ordnum (get-catattr object-1)) + (get-sort-ordnum (get-catattr object-2)))))))) + catattr-grp)) + (get-members locref-cls-grp)) + locref-cls-grp) + +#| +(defun separate-into-catattr-groups-old-version (locref-cls-grp) + (set-members (convert-sublists-to-group-objects + (split-list #'(lambda (object) + (get-catattr-grp-ordnum (get-catattr object))) + #'< + (get-members locref-cls-grp)) + 'category-attribute-group) + locref-cls-grp) + (mapc #'(lambda (catattr-grp) + (set-ordnum (get-catattr-grp-ordnum + (get-catattr (car (get-members catattr-grp)))) + catattr-grp) + (set-members + (sort (get-members catattr-grp) + #'(lambda (object-1 object-2) + (let ((ordnum-1 (get-ordnums object-1)) + (ordnum-2 (get-ordnums object-2))) + (or (locref-ordnum< ordnum-1 ordnum-2) + (and (locref-ordnum= ordnum-1 ordnum-2) + (< (get-sort-ordnum (get-catattr object-1)) + (get-sort-ordnum (get-catattr object-2)))))))) + catattr-grp)) + (get-members locref-cls-grp)) + locref-cls-grp) +|# + +;; line 992 "idxentry.nw" +(eval-when (compile load eval) + +;; line 127 "idxentry.nw" +(export '(index-entry make-index-entry + add-location-reference-to-indexentry)) +;; line 360 "idxentry.nw" +(export '(locref-group get-members + locref-class-group crossref-class-group get-locclass + make-locref-group process-group process-indexentry)) +;; line 603 "idxentry.nw" +(export '(process-group split-same-locrefs + apply-substitution-rules substitutable-p)) +;; line 664 "idxentry.nw" +(export '(apply-merge-rules)) +;; line 853 "idxentry.nw" +(export '(category-attribute-group)) +;; line 1021 "idxentry.nw" +(export '(*percentage-list* print-rest-of-percentages print-percent)) +;; line 994 "idxentry.nw" + ) +;; line 594 "ranges.nw" +;; $Id: ranges.nw,v 1.11 1997/03/26 16:18:41 kehr Exp $ + +;; line 68 "ranges.nw" +(defclass location-range () + ((length :initarg :length) + (first :initarg :first) + (last :initarg :last) + (layers :initarg :layers) + (ordnums :initarg :ordnums) + (inner :initarg :inner) + (locclass :initarg :locclass) + (catattr :initarg :catattr) + (subrefs :initform '()))) + +(defun make-location-range (&key length first last first-ordnum inner locclass) + (make-instance 'location-range + :length length + :first first + :last last + :inner inner + :ordnums first-ordnum + :layers (get-layers first) + :locclass locclass + :catattr (get-catattr first))) +;; line 581 "ranges.nw" +(defun ordnum-successor-p (ordnums-1 ordnums-2) + (declare (inline)) + (and ordnums-1 #|is there really something in it, or we are about to start?|# + (equal (butlast ordnums-1) (butlast ordnums-2)) + (equal (1+ (car (last ordnums-1))) + (car (last ordnums-2))))) +;; line 143 "ranges.nw" +(defmethod build-ranges ((locref-list list) + (idxcls indexclass) + (loccls var-location-class)) + locref-list) +;; line 321 "ranges.nw" +(defmacro newstat (s) + `(setq new-state ,s)) + +(defmacro pushl () + `(progn + (setq curr-ordnum (get-ordnums locref)) + (unless locref-stack + (setq first-ordnum curr-ordnum) + (setq first-locref locref)) + (setq prev-ordnum curr-ordnum) + (push locrefs locref-stack))) + +(defmacro pushone () + `(progn + (setq curr-ordnum (get-ordnums locref)) + (unless locref-stack + (setq first-ordnum curr-ordnum) + (setq first-locref locref)) + (setq prev-ordnum curr-ordnum) + (push (list (car locrefs)) locref-stack))) + +(defmacro set-open-range () + `(setq last-open-locref locref)) + +(defmacro keep () + `(setq back-flag t)) + +(defmacro make-range () + `(setq make-flag t)) +;; line 197 "ranges.nw" +(defmethod build-ranges ((locref-list list) + (idxcls indexclass) + (loccls standard-location-class)) + (let ((valid-list (mapcan #'(lambda (locref) + (unless (state-deleted-p locref) + (list locref))) + locref-list))) + (ifnot valid-list + '() + (ifnot (joining-allowed-p loccls) + valid-list + (let ((same-ordnum-list (split-same-locrefs valid-list)) + +;; line 353 "ranges.nw" +(locref-stack '()) +(result-list '()) +(state :START) +(join-length (get-join-length loccls)) +new-state +open-p close-p open+close-p no-typ-p list-end +make-flag back-flag +locrefs locref last-open-locref first-locref +first-ordnum prev-ordnum curr-ordnum +;; line 209 "ranges.nw" + ) + (loop + +;; line 365 "ranges.nw" +(setq locrefs (car same-ordnum-list)) +(setq list-end (null locrefs)) +(setq locref (car locrefs)) +(setq open-p (find-if #'(lambda (locref) + (rangeattr-open-p (get-rangeattr locref))) + locrefs)) +(setq close-p (find-if #'(lambda (locref) + (rangeattr-close-p (get-rangeattr locref))) + locrefs)) +(setq open+close-p (and open-p close-p)) +(setq no-typ-p (not (or open-p close-p))) +;; line 212 "ranges.nw" + (ecase state + (:START +;; line 230 "ranges.nw" +(cond (list-end (return (apply #'nconc #| see note below for explanation |# + (apply #'nconc result-list)))) + (no-typ-p (newstat :READ) (pushl)) + (open+close-p (newstat :READ) (pushone)) + (open-p (newstat :OPEN-RANGE) (pushl) (set-open-range)) + (close-p (warn-invalid-close locref) (newstat :START)) + (t (error + "INTERNAL-ERROR in build-ranges - :START"))) +;; line 213 "ranges.nw" + ) + (:READ +;; line 267 "ranges.nw" +(if list-end + (progn (newstat :START) (make-range)) + (progn + (setq curr-ordnum (get-ordnums locref)) + (let ((succ-p (ordnum-successor-p prev-ordnum curr-ordnum))) + (cond ((and succ-p no-typ-p) (pushl)) + ((and succ-p open+close-p) (pushone)) + ((or no-typ-p + (not (and succ-p + open-p))) (newstat :START) (keep) (make-range)) + (open-p (newstat :OPEN-RANGE) + (pushl) (set-open-range)) + (close-p (warn-invalid-close locref) (newstat :READ)) + (t (error "INTERNAL-ERROR in build-ranges - :READ")))))) +;; line 214 "ranges.nw" + ) + (:OPEN-RANGE +;; line 288 "ranges.nw" +(cond (list-end +;; line 297 "ranges.nw" +(warn + (with-output-to-string (s) + (format s "Found no :close-range matching an already opened one!~%") + (format s "Location-reference is ~A in keyword ~A.~%" + (get-locref-string last-open-locref) + (get-main-key *currently-processed-indexentry*)) + (format s "Maybe I lost some of the regular location-references.~%"))) +;; line 288 "ranges.nw" + (newstat :START)) + ((or no-typ-p open+close-p) (pushl)) + (open-p +;; line 307 "ranges.nw" +(warn + (with-output-to-string (s) + (format s "Found :open-range that was already opened!~%") + (format s "Location-references are ~A and ~A in keyword ~A.~%" + (get-locref-string last-open-locref) + (get-locref-string locref) + (get-main-key *currently-processed-indexentry*)) + (format s "I'll continue and ignore this.~%"))) +;; line 291 "ranges.nw" + (newstat :OPEN-RANGE)) + (close-p (newstat :READ) (pushl)) + (t (error "INTERNAL-ERROR in build-ranges - :OPEN-RANGE"))) +;; line 215 "ranges.nw" + )) + +;; line 402 "ranges.nw" +(when make-flag + (let ((range-len (- (car (last prev-ordnum)) (car (last first-ordnum))))) + (if (>= range-len join-length) + (push (list (list + (make-location-range :first-ordnum first-ordnum + :locclass loccls + :inner locref-stack + :first first-locref + :last (caar locref-stack) + :length range-len))) + result-list) + (push locref-stack result-list)) + (setq locref-stack '()) + (setq make-flag nil))) +(if back-flag + (setq back-flag nil) + (setq same-ordnum-list (cdr same-ordnum-list))) +(setq state new-state) +;; line 216 "ranges.nw" + )))))) +;; line 241 "ranges.nw" +(defun warn-invalid-close (locref) + (warn + (with-output-to-string (s) + (format s "Found a :close-range in the index that wasn't opened before!~%") + (format s "Location-reference is ~A in keyword ~A~%" + (get-locref-string locref) + (get-main-key *currently-processed-indexentry*)) + (format s "I'll continue and ignore this.~%")))) +;; line 509 "ranges.nw" +(defmethod post-process ((locrange location-range) (drop-function function)) + (let ((locref-list (apply #'nconc (get-inner locrange)))) + (cond ((>= (get-length locrange) + (get-join-length (get-locclass locrange))) + (mapc #'(lambda (locref) + (let ((origin (get-origin locref))) + (when origin + (funcall drop-function origin)))) + locref-list) + ;;(set-inner '() locrange) + locrange) + (t locref-list)))) + +;(defmethod post-process ((locref-list list) x) +; (declare (ignore x)) +; locref-list) + +(defmethod post-process ((locref location-reference) x) + (declare (ignore x)) + locref) + +;; line 600 "ranges.nw" +(eval-when (compile load eval) + +;; line 92 "ranges.nw" +(export '(location-range get-first get-last get-length)) +;; line 602 "ranges.nw" + ) +;; line 88 "index.nw" +(defparameter *index-entry-table* nil) #| faster access to the entry-table |# +;; line 69 "index.nw" +(defconstant *all-hierarchy-layers* MOST-POSITIVE-FIXNUM) + +(defclass base-index () + ((entry-table :initform (make-hash-table :test #'equal)) + (entry-list :initform '()) + (entries :initform '()) + (idxclass :initarg :idxclass) + (hierdepth :initform *all-hierarchy-layers*))) + +(defun make-base-index (idxclass) + (make-instance 'base-index :idxclass idxclass)) +;; line 542 "index.nw" +(defclass letter-group () + ((members :initarg :members :type list) + (group-definition :initarg :group-definition))) +;; line 555 "index.nw" +(defun make-letter-group (members) + (make-instance 'letter-group + :members members + :group-definition (match-letter-group + *indexstyle* + (car (get-sort-key (car members)))))) + +;; line 273 "index.nw" +(defun add-layered-locref-indexentry (&key + (entry-table *index-entry-table*) + (idxcls *indexstyle*) + locref main-key + (merge-key '()) + (print-key '()) + (open-range nil) (close-range nil) + (catattr nil) (attribute nil)) + #+:ASSERT! (assert! (and main-key locref)) + + (if (and open-range close-range) + +;; line 320 "index.nw" +(nraw "specification of both :open-range and :close-range is invalid! (ignored)") +;; line 285 "index.nw" + (progn + (when (or (not catattr) + (string= catattr "")) + (setq catattr "default")) + (let ((catattr-obj (lookup-catattr idxcls catattr))) + (if (not catattr-obj) + (nraw "unknown attribute `~A'! (ignored)" catattr) + (multiple-value-bind (num location-reference) + (create-location-reference-from-string + locref catattr-obj attribute) + (when (eql 1 num) + #| ; + Only one vaild location-reference! Use #'eql and + not #'= since we compare num against NIL, too. + |# + +;; line 359 "index.nw" +#+:ORDRULES (unless merge-key + (setq merge-key (gen-keyword-mergekey-list main-key))) +#-:ORDRULES (unless merge-key (setq merge-key main-key)) +;; line 301 "index.nw" + (cond (open-range (set-rangeattr-open location-reference)) + (close-range (set-rangeattr-close location-reference))) + (let ((old-entry (gethash merge-key entry-table))) + (if old-entry + (setf (gethash merge-key entry-table) + (join-indexentries + old-entry;;(gethash merge-key entry-table) + main-key print-key + location-reference)) + (setf (gethash merge-key entry-table) + (make-index-entry :main-key main-key + :merge-key merge-key + :print-key print-key + :locrefs (list + location-reference) + :indexclass idxcls))))))))))) +;; line 324 "index.nw" +(defun add-crossref-indexentry (&key + (entry-table *index-entry-table*) + (idxcls *indexstyle*) + (merge-key '()) + (print-key '()) + main-key + xref + xref-class-name + (attribute nil)) + #+:ASSERT! (assert! (and main-key xref xref-class-name)) + + (unless xref-class-name (setq xref-class-name "default")) + (let ((xref-class (cdr (lookup-crossref-class idxcls xref-class-name)))) + (if (not xref-class) + (nraw "unknown cross-reference-class `~A'! (ignored)~%" + xref-class-name) + (let ((cross-reference (create-cross-reference xref-class + xref attribute))) + (when cross-reference + +;; line 359 "index.nw" +#+:ORDRULES (unless merge-key + (setq merge-key (gen-keyword-mergekey-list main-key))) +#-:ORDRULES (unless merge-key (setq merge-key main-key)) +;; line 344 "index.nw" + (let ((old-entry (gethash merge-key entry-table))) + (if old-entry + (setf (gethash merge-key entry-table) + (join-indexentries old-entry ;;(gethash merge-key entry-table) + main-key print-key + cross-reference)) + (setf (gethash merge-key entry-table) + (make-index-entry :main-key main-key + :merge-key merge-key + :print-key print-key + :locrefs (list cross-reference) + :indexclass idxcls))))))))) +;; line 367 "index.nw" +#+:ORDRULES +(defun gen-keyword-mergekey-list (list-of-strings) + #+ASSERT! (assert! (and (not (null list-of-strings)) + (listp list-of-strings))) + (let ((res (mapcar #'(lambda (str) + (gen-keyword-mergekey str)) + list-of-strings))) + (flush-ordrules-message-buffer) + res)) + +#+:ORDRULES +(defun gen-keyword-sortkey-list (list-of-strings run) + #+ASSERT! (assert! (and (not (null list-of-strings)) + (listp list-of-strings) + (<= 0 run) (run < 8))) + (let ((res (mapcar #'(lambda (str) + (gen-keyword-sortkey str run)) + list-of-strings))) + (flush-ordrules-message-buffer) + res)) +;; line 398 "index.nw" +(defun join-indexentries (idxent main-key print-key locref) + (let ((old-main-key (get-main-key idxent)) + (old-print-key (get-print-key idxent))) + (unless old-main-key (set-main-key main-key idxent)) + (set-print-key (mapcar #'(lambda (old curr) + (or old curr)) + old-print-key print-key) + idxent) + ;; (info "~&(join-indexentries :old-main-key ~S :old-print-key ~S :new-print-key ~S)" + ;; old-main-key old-print-key (get-print-key idxent)) + (add-location-reference-to-indexentry idxent locref))) +;; line 438 "index.nw" +(defun create-location-reference-from-string (locref-str catattr attribute) + (let* ((idxcls *indexstyle*)) + (multiple-value-bind (num locref) + (lookup-locref-cache idxcls locref-str) + (if num #| something was found! |# + (case num + (0 +;; line 474 "index.nw" +(nraw "location-reference ~S did not match any location-class! (ignored)" + locref-str) +;; line 445 "index.nw" + (values nil nil)) + (1 (values 1 (copy-locref-from-template locref catattr attribute)) + #| return its only member |#) + (t +;; line 469 "index.nw" +(nraw "location-reference ~S did match multiple location-classes! (taking first one)" + locref-str) +;; line 449 "index.nw" + (values num (copy-locref-from-template locref catattr attribute)) + #| return a copy of the stored template |#)) + (let ((locref-list + (map-location-classes + idxcls + #'(lambda (idxcls loccls) + (declare (ignore idxcls)) + (build-location-reference loccls locref-str + catattr attribute))))) + (case (length locref-list) + (0 +;; line 474 "index.nw" +(nraw "location-reference ~S did not match any location-class! (ignored)" + locref-str) +;; line 460 "index.nw" + (add-locref-cache idxcls locref-str 0 nil)) + (1 (add-locref-cache idxcls locref-str 1 (car locref-list)) + #| return its only member |#) + (t +;; line 469 "index.nw" +(nraw "location-reference ~S did match multiple location-classes! (taking first one)" + locref-str) +;; line 464 "index.nw" + (add-locref-cache idxcls locref-str 1 (car locref-list)) + #| return its first member |#))))))) +;; line 482 "index.nw" +(defun copy-locref-from-template (locref catattr attribute) + (declare (inline)) + (make-layered-location-reference :catattr catattr + :attribute attribute + :string (get-locref-string locref) + :locclass (get-locclass locref) + :layers (copy-list (get-layers locref)) + :ordnums (copy-list (get-ordnums locref)))) +;; line 727 "index.nw" +(defun sort-indexentries (indexentries) + #+:ASSERT! (assert! (listp indexentries)) + (gol t "~&sort-indexentries: ~S" *sort-rule-orientations*) + (sort indexentries + #'(lambda (idxent-1 idxent-2) + (multiple-value-bind (less-equal? equal?) + (strlist<= (get-sort-key idxent-1) + (get-sort-key idxent-2) + (first *sort-rule-orientations*)) + (if equal? + (sort-other-runs (get-merge-key idxent-1) + (get-merge-key idxent-2) + (rest *sort-rule-orientations*) + 1) + less-equal?))))) +;; line 751 "index.nw" +(defun sort-other-runs (merge-key-1 merge-key-2 orientations run) + (gol t "~&sort-other-runs: ~S ~S ~S ~S." + merge-key-1 merge-key-2 orientations run) + (cond ((endp orientations) + (nraw "Sort rules could not define exact order of key ~S." + merge-key-1) + nil) + (t (let ((key-1 (mapcar #'(lambda (key) + (gen-keyword-sortkey key run)) + merge-key-1)) + (key-2 (mapcar #'(lambda (key) + (gen-keyword-sortkey key run)) + merge-key-2))) + (flush-ordrules-message-buffer) + (multiple-value-bind (less-equal? equal?) + (strlist<= key-1 key-2 (first orientations)) + (if equal? + (sort-other-runs merge-key-1 merge-key-2 + (rest orientations) (1+ run)) + less-equal?)))))) +;; line 782 "index.nw" +(defun oriented-string (string orientation) + (declare (inline)) + (cond ((eql orientation 'forward) string) + ((eql orientation 'backward) (reverse string)) + (t (error "INDEX:ORIENTED-STRING wrong orientation!")))) +;; line 793 "index.nw" +(defun strlist<= (slist-1 slist-2 orientation) + (declare (inline)) + (cond ((endp slist-1) (values t (endp slist-2))) + ((endp slist-2) (values nil nil)) + (t (let ((str-1 (oriented-string (first slist-1) orientation)) + (str-2 (oriented-string (first slist-2) orientation))) + (let ((pos (string/= str-1 str-2))) + (if pos + (let ((lt (string< str-1 str-2))) + (if lt + (values t nil) + (values nil (string= str-1 str-2)))) + (strlist<= (cdr slist-1) (cdr slist-2) orientation))))))) +#| +(strlist<= '("foo") '("foo") 'forward) +(strlist<= '("fool") '("foo") 'forward) +(strlist<= '("foo") '("fool") 'forward) +(strlist<= '("foo") '("fool") 'backward) +(strlist<= '("foo") '("foo" "bar") 'forward) +(strlist<= '("foo" "bar") '("foo") 'forward) +(strlist<= '("foo" "bar") '("foo") 'backward) +|# + + +#+OLDVER +(defun strlist< (string-list-1 string-list-2) + (declare (inline)) + (do ((rest-1 string-list-1 (cdr rest-1)) + (rest-2 string-list-2 (cdr rest-2))) + ((or (endp rest-1) (endp rest-2) + (string/= (first rest-1) (first rest-2))) + (or (endp rest-1) + (if (endp rest-2) + 'nil + (string< (first rest-1) (first rest-2))))))) +;; line 504 "index.nw" +(defmethod process-index ((index base-index)) + (let ((hash-list '())) + (maphash #'(lambda (key idxentry) + (declare (ignore key)) + (setq hash-list (cons idxentry hash-list))) + (get-entry-table index)) + (set-entry-list hash-list index) + (build-indexentry-tree index) + + (setq *number-of-indexentries* (length (get-entry-list index))) + (setq *current-number* 0) + (setq *percentage-list* + (mapcar #'(lambda (percent) + (cons (truncate (* (/ percent 100) + *number-of-indexentries*)) + percent)) + ;; MOST-POSITIVE-FIXNUM acts as sentinel such that + ;; we never run out of elements + `(10 20 30 40 50 60 70 80 90 100 ,MOST-POSITIVE-FIXNUM))) + (setq *processing-percentage-list* *percentage-list*) + (mapc #'process-indexentry (get-entry-list index)) + (print-rest-of-percentages *processing-percentage-list*) + index)) +;; line 568 "index.nw" +(defmethod build-indexentry-tree ((index base-index)) + (let ((index-hierdepth (get-hierdepth index))) + (gol t "~&~%Building indexentry-tree:~%") + (gol t "Hierdepth of index is ~S~%~%" + (if (= index-hierdepth most-positive-fixnum) + :tree index-hierdepth)) + (set-entries (build-indexentry-tree-recursive (get-entry-list index) + index-hierdepth) + index) + (gol t "~&~%Forming letter-groups:~%") + (let ((letter-groups (split-list #'(lambda (idxent) + (get-ordnum + (match-letter-group + *indexstyle* + (car (get-sort-key idxent))))) + (get-entries index) + :sortfunc #'<))) + (set-entries (mapcar #'(lambda (lg-indexentries) + (make-letter-group + (sort-indexentries lg-indexentries))) + letter-groups) + index)))) +;; line 622 "index.nw" +(defun build-indexentry-tree-recursive (idxent-list + max-depth + &optional (curr-depth 1)) + (cond ((endp idxent-list) idxent-list) #| nothing more to do |# + ((> curr-depth max-depth) #| we reached the end |# + (gen-all-sort-keys idxent-list) #| this is the then case |# + ) + (t (let ((idxent-slist + (split-list #'(lambda (idxent) + (car (get-merge-key idxent))) + idxent-list + :headfunc + #'(lambda (idxent) + (= 1 (length (get-merge-key idxent))))))) + (mapcar + #'(lambda (sublist) + (let* ((idxent (car sublist)) + (merge-key (get-merge-key idxent))) + (if (= 1 (length merge-key)) + (progn #| length = 1 |# + (set-sort-key #-:ORDRULES merge-key + #+:ORDRULES (gen-keyword-sortkey-list + merge-key 0) + idxent) + (set-subentries + (sort-indexentries + (build-indexentry-tree-recursive + (remove-first-keywords (cdr sublist)) + max-depth + (1+ curr-depth))) + idxent) + idxent) + (let* #| length > 1 |# + ((main-key (get-main-key idxent)) + (new-merge-key (take-first merge-key)) + (some-print-key (find-print-key sublist)) + (new-print-key (list (or some-print-key + (car main-key)))) + (new-idxent + (make-index-entry + :main-key (take-first main-key) + :merge-key new-merge-key + :print-key new-print-key + :sort-key + #-:ORDRULES new-merge-key + #+:ORDRULES (gen-keyword-sortkey-list + new-merge-key 0) + :idxclass (get-idxclass idxent)))) + ;; (info "~&(treeing :main ~S :some-print ~S :new-print ~S)" + ;; main-key some-print-key new-print-key) + (set-subentries + (sort-indexentries + (build-indexentry-tree-recursive + (remove-first-keywords sublist) + max-depth + (1+ curr-depth))) + new-idxent) + new-idxent)))) + idxent-slist))))) + +(defun find-print-key (idxent-list) + (some #'(lambda (idxent) + (car (get-print-key idxent))) + idxent-list)) +;; line 689 "index.nw" +(defun remove-first-keywords (idxent-list) + (declare (inline)) + (mapc #'(lambda (idxent) + (setf (slot-value idxent 'merge-key) + (cdr (slot-value idxent 'merge-key))) + (setf (slot-value idxent 'main-key) + (cdr (slot-value idxent 'main-key))) + (setf (slot-value idxent 'print-key) + (cdr (slot-value idxent 'print-key))) + ) + idxent-list) + idxent-list) +;; line 713 "index.nw" +(defun gen-all-sort-keys (idxent-list) + (when idxent-list + (mapc #'(lambda (idxent) + (set-sort-key #-:ORDRULES (get-merge-key idxent) + #+:ORDRULES (gen-keyword-sortkey-list + (get-merge-key idxent) 0) + idxent)) + idxent-list)) + idxent-list) +;; line 94 "index.nw" +(defparameter *index* nil) + +(defun create-index () + (setq *index* (make-base-index *indexstyle*)) + (setq *index-entry-table* (get-entry-table *index*)) + *index*) + +(create-index) +;; line 421 "index.nw" +(defun lookup-indexentry (key &optional (index-entry-table *index-entry-table*)) + (gethash key index-entry-table)) + +;; line 258 "index.nw" +(eval-when (compile load eval) + (defparameter *raw-index-interface-definitions* + '(indexentry))) +;; line 165 "index.nw" +(defmacro indexentry (&whole whole &rest args) + (destructuring-switch-bind (&key + key print tkey merge attr locref xref + &switch + (open-range :open-range) + (close-range :close-range)) + args + (cond ((not (or key tkey)) + (error "missing argument :key or :tkey in~%~S.")) + ((and key tkey) + (error "you can't specify :key and :tkey at the same time in~%~S." + whole)) + ((and locref xref) +;; line 213 "index.nw" +(error "you can't specify :locref and :xref at the same time in~%~S." + whole) + +;; line 177 "index.nw" + ) + (t (progn + (if tkey + (multiple-value-setq (key print) + (tkey-to-normal-key tkey whole)) + (when print;; check for correct key-length + (let ((keylen (length key))) + (unless (= keylen (length print)) + (setq print;; take the first keylen elmts of print + (mapcar #'(lambda (x y) (declare (ignore y)) x) + key + (append print (make-list keylen)))))))) + (cond ((not (listp key)) + (error ":key ~S is not a list in~%~S." key whole)) + ((not (listp print)) + (error ":print ~S is not a list in~%~S." print whole)) + (locref `(ADD-LAYERED-LOCREF-INDEXENTRY + :MAIN-KEY ',key + :PRINT-KEY ',print + :MERGE-KEY ',merge + :CATATTR ',attr + :LOCREF ',locref + :OPEN-RANGE ',open-range + :CLOSE-RANGE ',close-range)) + (xref (when (or open-range close-range) + +;; line 221 "index.nw" +(error "you can't specify :open-range or :close-range with :xref at the same time in~%~S." + whole) +;; line 202 "index.nw" + ) + (unless attr +;; line 217 "index.nw" +(error "missing :attr in combination with :xref in~%~S." whole) +;; line 203 "index.nw" + ) + `(ADD-CROSSREF-INDEXENTRY + :MAIN-KEY ',key + :PRINT-KEY ',print + :XREF ',xref + :XREF-CLASS-NAME ',attr)) + (t +;; line 226 "index.nw" +(error "you must at least specify :locref or :xref in~%~S." whole) +;; line 209 "index.nw" + ))))))) +;; line 238 "index.nw" +(defun tkey-to-normal-key (tkey whole) + (when (not (listp tkey)) +;; line 254 "index.nw" +(error "INDEXENTRY: invalid structure of :tkey in~%~S." tkey whole) +;; line 239 "index.nw" + ) + (let ((main-key '()) + (print-key '())) + (mapc #'(lambda (key-elt) + (cond ((listp key-elt) + (push (car key-elt) main-key) + (if (cdr key-elt) + (push (cadr key-elt) print-key) + (push nil print-key))) + (t +;; line 254 "index.nw" +(error "INDEXENTRY: invalid structure of :tkey in~%~S." tkey whole) +;; line 248 "index.nw" + ))) + tkey) + (values (nreverse main-key) (nreverse print-key)))) + +;; line 889 "index.nw" +(eval-when (compile load eval) + +;; line 83 "index.nw" +(export '(base-index make-base-index get-entries)) +;; line 105 "index.nw" +(export '(*index* create-index)) +;; line 264 "index.nw" +(export '*raw-index-interface-definitions*) +(export *raw-index-interface-definitions*) +;; line 412 "index.nw" +(export '(add-locref-indexentry add-crossref-indexentry)) +;; line 530 "index.nw" +(export '(process-index)) +;; line 564 "index.nw" +(export '(letter-group get-members get-group-definition)) +;; line 891 "index.nw" + ) + +;; line 1029 "idxentry.nw" +#+:XP +(set-pprint-dispatch 'index-entry + #'(lambda (s idxent) + (pprint-logical-block + (s nil :suffix "}") + (pprint-indent :block 2 s) + (write-string "Indexentry {" s) + (pprint-newline :mandatory s) + (write-string "main-key: " s) + (write (get-main-key idxent) :stream s) + (pprint-newline :mandatory s) + (write-string "merge-key: " s) + (write (get-merge-key idxent) :stream s) + (pprint-newline :mandatory s) + (write-string "sort-key: " s) + (write (get-sort-key idxent) :stream s) + (pprint-newline :mandatory s) + (pprint-logical-block + (s nil :suffix "}") + (write-string "Locrefs {" s) + (pprint-indent :block 2) + (pprint-newline :mandatory s) + (pprint-linear s (get-locrefs idxent))) + (pprint-newline :mandatory s) + (pprint-logical-block + (s nil :suffix "}") + (write-string "Subentries {" s) + (pprint-indent :block 2) + (pprint-newline :mandatory s) + (pprint-linear s (get-subentries idxent))) + (pprint-newline :mandatory s)) + )) +;; line 1071 "idxentry.nw" +#+:XP +(defun pprint-locref-group (s grp name) + (format s "~%") + (pprint-logical-block + (s nil :prefix "(" :suffix ")") + (write-string name s) + (write-string ":" s) + (when (typep grp 'category-attribute-group) + (write (get-ordnum grp) :stream s)) + (pprint-indent :block 2 s) + (pprint-newline :mandatory s) + (pprint-fill s (get-members grp) nil) + (pprint-indent :block -1 s) + (pprint-newline :mandatory s))) + +#+:XP +(defun set-pprint-locref-group-dispatch (class name &optional (rank 0)) + (set-pprint-dispatch class + #'(lambda (s grp) + (pprint-locref-group s grp name)) + rank)) +;; line 1107 "idxentry.nw" +#+:XP +(set-pprint-locref-group-dispatch 'locref-group + "LOCREF-GROUP" 0) +#+:XP +(set-pprint-locref-group-dispatch 'locref-class-group + "LOCREF-CLASS-GROUP" 1) +#+:XP +(set-pprint-locref-group-dispatch 'crossref-class-group + "CROSSREF-CLASS-GROUP" 2) +#+:XP +(set-pprint-locref-group-dispatch 'category-attribute-group + "CATEGORY-ATTRIBUTE-GROUP" 3) +;; line 614 "ranges.nw" +#+:XP +(defun pprint-location-range (s range) + (pprint-logical-block + (s nil :prefix "[" :suffix "]") + (format s "range: ~D " (get-length range)) + (pprint-newline :fill s) + (write-string " loccls: " s) + (write (get-locclass range) :stream s) + (pprint-newline :fill s) + (write-string " catattr: " s) + (write (get-catattr range) :stream s) + (format s "/~D" (get-sort-ordnum (get-catattr range))) + (pprint-newline :fill s) + (format s " ordnums: ~A " (get-ordnums range)) + (pprint-newline :fill s) + (pprint-logical-block + (s nil :prefix "<" :suffix ">") + (write-string "first " s) + (pprint-newline :miser s) + (write (get-first range) :stream s)) + (pprint-newline :mandatory s) + (pprint-logical-block + (s nil :prefix "<" :suffix ">") + (write-string "inner " s) + (pprint-newline :linear s) + (write (get-inner range) :stream s)) + (pprint-newline :mandatory s) + (pprint-logical-block + (s nil :prefix "<" :suffix ">") + (write-string "last " s) + (pprint-newline :miser s) + (write (get-last range) :stream s)) + (pprint-newline :mandatory s))) + +#+:XP +(set-pprint-dispatch 'location-range #'pprint-location-range) + +;; line 868 "index.nw" +(defvar *RCS-Identifier* '( +;; line 998 "idxentry.nw" +("idxentry" . "$Id: idxentry.nw,v 1.29 1997/03/27 17:17:25 kehr Exp $") +;; line 895 "index.nw" +("index" . "$Id: index.nw,v 1.31 1997/03/26 16:18:37 kehr Exp $") +;; line 606 "ranges.nw" +("ranges" . "$Id: ranges.nw,v 1.11 1997/03/26 16:18:41 kehr Exp $") +;; line 868 "index.nw" + )) diff --git a/Build/source/utils/xindy/xindy-2.4/src/locref.lsp b/Build/source/utils/xindy/xindy-2.4/src/locref.lsp new file mode 100644 index 00000000000..428b629e910 --- /dev/null +++ b/Build/source/utils/xindy/xindy-2.4/src/locref.lsp @@ -0,0 +1,556 @@ +;; line 360 "locref.nw" +;; $Id: locref.nw,v 1.29 1997/03/26 16:18:53 kehr Exp $ + +(lisp:defpackage "LOCREF") +(lisp:in-package "LOCREF") +(lisp:provide "locref") + +#+CLISP (lisp:require "base") + +(eval-when (compile load eval) + #-CLISP (lisp:require "base") + (lisp:use-package "BASE") + #+(and :XP CLISP) (lisp:use-package "XP") + (lisp:use-package "CLOS")) + +;; line 251 "basetype.nw" +;; $Id: basetype.nw,v 1.17 1997/03/26 16:18:47 kehr Exp $ + +;; line 110 "basetype.nw" +(defgeneric prefix-match (str object)) +;; line 114 "basetype.nw" +(defclass basetype () + ((name :initarg :name) + (base-alphabet :initarg :base-alphabet))) +;; line 142 "basetype.nw" +(defclass alphabet (basetype) + ((symbols :initarg :symbols))) + +(defun make-alphabet (name symbols) + (make-instance 'alphabet :name name :symbols symbols + :base-alphabet (calculate-base-alphabet symbols))) + +(defmethod make-copy ((alph alphabet) new-name) + (make-instance 'alphabet + :name new-name + :symbols (get-symbols alph) + :base-alphabet (get-base-alphabet alph))) +;; line 163 "basetype.nw" +(defun calculate-base-alphabet (list-of-strings) + (sort (remove-duplicates + (apply #'nconc + (mapcar #'(lambda (str) + (coerce str 'list)) + list-of-strings))) + #'char<)) +;; line 183 "basetype.nw" +(defmethod prefix-match ((str string) (alph alphabet)) + (multiple-value-bind (matched-string rest-string order-num) + (prefix-match-stringlist str (get-symbols alph)) + (values matched-string rest-string order-num))) + +(defun prefix-match-stringlist (pattern list-of-str) + (let* ((matched-string "") + (rest-string pattern) + (ordnum-of-max-match nil) + (len-max-match 0) + (strlen (length pattern))) + (do ((ordnum 0 (1+ ordnum)) + (string-list list-of-str (cdr string-list))) + ((endp string-list)) + (let ((len-curr-match (string/= pattern (car string-list)))) + (when (null len-curr-match) (setq len-curr-match strlen)) + (when (> len-curr-match len-max-match) + (setq ordnum-of-max-match ordnum) + (setq len-max-match len-curr-match) + (setq rest-string (subseq pattern len-curr-match)) + (setq matched-string + (subseq (car string-list) 0 len-curr-match))))) + (values matched-string rest-string ordnum-of-max-match))) +;; line 227 "basetype.nw" +(defclass enumeration (basetype) + ()) + +(defun make-enumeration (enum-class name base-alphabet) + (make-instance enum-class + :name name + :base-alphabet base-alphabet)) + +(defmethod make-copy ((enum enumeration) new-name) + (make-instance (class-name (class-of enum)) + :name new-name + :base-alphabet (get-base-alphabet enum))) + +;; line 257 "basetype.nw" +(eval-when (compile load eval) + +;; line 120 "basetype.nw" +(export '(basetype prefix-match get-name get-base-alphabet)) +;; line 157 "basetype.nw" +(export '(alphabet make-alphabet get-symbols make-copy)) +;; line 242 "basetype.nw" +(export '(enumeration make-enumeration)) +;; line 259 "basetype.nw" + ) +;; line 493 "locclass.nw" +;; $Id: locclass.nw,v 1.21 1997/03/26 16:18:49 kehr Exp $ + +;; line 67 "locclass.nw" +(defclass location-class () + ((name :type string :initarg :name) + (ordnum :type number :initform (gen-next-loccls-ordnum)))) +;; line 87 "locclass.nw" +(defparameter *curr-loccls-ordnum* 0) + +(defun gen-next-loccls-ordnum () + (incf *curr-loccls-ordnum*)) +;; line 106 "locclass.nw" +(defclass layered-location-class (location-class) + ((layers :initarg :layers) + (hierdepth :initarg :hierdepth))) +;; line 125 "locclass.nw" +(defclass standard-location-class (layered-location-class) + ((join-length :initarg :join-length))) + +(defun make-standard-location-class (name layers join-length hierdepth) + (make-instance 'standard-location-class + :name name :layers layers + :join-length join-length :hierdepth hierdepth)) +;; line 135 "locclass.nw" +(defmacro joining-allowed-p (loccls) + `(SLOT-VALUE ,loccls 'JOIN-LENGTH)) +;; line 144 "locclass.nw" +(defun checked-make-standard-location-class (name layers join-layers + &optional (hierdepth 0)) + (make-standard-location-class name layers join-layers hierdepth)) +;; line 163 "locclass.nw" +(defclass var-location-class (layered-location-class) + ()) + +(defun make-var-location-class (name layers hierdepth) + (make-instance 'var-location-class + :name name :layers layers :hierdepth hierdepth)) +;; line 172 "locclass.nw" +(defun checked-make-var-location-class (name layers &optional (hierdepth 0)) + (make-var-location-class name layers hierdepth)) +;; line 189 "locclass.nw" +(defclass loccls-layer () + ((basetype :initarg :basetype))) + +(defun make-loccls-layer (basetype) + (make-instance 'loccls-layer :basetype basetype)) +;; line 206 "locclass.nw" +(defmethod prefix-match ((locstring string) + (layer loccls-layer)) + (prefix-match locstring (get-basetype layer))) +;; line 220 "locclass.nw" +(defclass loccls-separator () + ((separator :initarg :separator))) + +(defun make-loccls-separator (separator) + (make-instance 'loccls-separator :separator separator)) +;; line 246 "locclass.nw" +(defmethod prefix-match ((locstring string) + (separator loccls-separator)) + (let* ((sepstr (get-separator separator)) + (seplen (length sepstr)) + (match-len (string/= sepstr locstring))) + (if (or (null match-len) (eql seplen match-len)) + (values locstring (subseq locstring seplen) t) + (values nil nil nil)))) +;; line 273 "locclass.nw" +(defclass crossref-location-class (location-class) + ((target :initarg :target))) +;; line 299 "locclass.nw" +(defclass verified-crossref-location-class (crossref-location-class) + ()) + +(defun make-verified-crossref-location-class (name) + (make-instance 'verified-crossref-location-class :name name)) +;; line 319 "locclass.nw" +(defclass unverified-crossref-location-class (crossref-location-class) + ()) + +(defun make-unverified-crossref-location-class (name) + (make-instance 'unverified-crossref-location-class :name name)) + +;; line 374 "locclass.nw" +(defgeneric perform-match (locstring locclass)) +;; line 402 "locclass.nw" +(defmethod perform-match ((locstring string) + (loccls standard-location-class)) + (let ((layer-list '()) + (ordnum-list '()) + (give-up nil) + (matched-string nil) + (rest-string nil) + (ordnum nil)) + (do ((layers (get-layers loccls) (cdr layers))) + ((or give-up + (let ((empty-string (= 0 (length locstring))) + (empty-list (endp layers))) + (cond ((and empty-string empty-list) t) + ((or empty-string empty-list) (setq give-up t)) + (t nil))))) + (let ((curr-layer (car layers))) + (multiple-value-setq (matched-string rest-string ordnum) + (prefix-match locstring curr-layer)) + (cond ((eq ordnum nil) (setq give-up t)) + ((numberp ordnum) + (setq locstring rest-string) + (setq layer-list + (cons matched-string layer-list)) + (setq ordnum-list (cons ordnum ordnum-list))) + (t (setq locstring rest-string))) + )) + (if (not give-up) + (values (nreverse layer-list) (nreverse ordnum-list)) + (values nil nil)))) +;; line 446 "locclass.nw" +(defmethod perform-match ((locstring string) + (loccls var-location-class)) + (let ((layer-list '()) + (ordnum-list '()) + (give-up nil) + (matched-string nil) + (rest-string nil) + (ordnum nil)) + (do ((layers (get-layers loccls) (cdr layers))) + ((or give-up + (let ((empty-string (= 0 (length locstring))) + (empty-list (endp layers))) + (cond (empty-string t) + (empty-list (setq give-up t)) + (t nil))))) + (let ((curr-layer (car layers))) + (multiple-value-setq (matched-string rest-string ordnum) + (prefix-match locstring curr-layer)) + (cond ((eq ordnum nil) (setq give-up t)) + ((numberp ordnum) + (setq locstring rest-string) + (setq layer-list + (cons matched-string layer-list)) + (setq ordnum-list (cons ordnum ordnum-list))) + (t (setq locstring rest-string))) + )) + (if (not give-up) + (values (nreverse layer-list) (nreverse ordnum-list)) + (values nil nil)))) +;; line 482 "locclass.nw" +;; FIXME (do we need this) +;;(defmethod perform-match ((locstring string) +;; (loccls crossref-location-class)) +;; t) + +;; line 507 "locclass.nw" +(eval-when (compile load eval) + +;; line 94 "locclass.nw" +(export '(location-class perform-match + get-name get-ordnum set-ordnum ordnum)) +;; line 112 "locclass.nw" +(export '(layered-location-class)) +;; line 150 "locclass.nw" +(export '(standard-location-class checked-make-standard-location-class + get-join-length set-join-length + joining-allowed-p join-length)) +;; line 177 "locclass.nw" +(export '(var-location-class checked-make-var-location-class)) +;; line 197 "locclass.nw" +(export '(loccls-layer make-loccls-layer + get-basetype get-markup)) +;; line 228 "locclass.nw" +(export '(loccls-separator make-loccls-separator + get-separator get-markup)) +;; line 278 "locclass.nw" +(export '(crossref-location-class get-target)) +;; line 307 "locclass.nw" +(export '(verified-crossref-location-class + make-verified-crossref-location-class)) +;; line 327 "locclass.nw" +(export '(unverified-crossref-location-class + make-unverified-crossref-location-class)) +;; line 183 "locref.nw" +(export '(crossref-location-reference create-cross-reference)) +;; line 215 "locref.nw" +(export 'build-location-reference) +;; line 509 "locclass.nw" + ) +;; line 56 "locref.nw" +(defclass location-reference () + ((locclass :initarg :locclass) + (attribute :initarg :attribute))) +;; line 78 "locref.nw" +(defclass layered-location-reference (location-reference) + ((layers :initarg :layers) + (locref-string :initarg :string :type string) + (ordnums :initarg :ordnums) + (catattr :initarg :catattr) + (state :initarg :state) + (rangeattr :initform 'nil) + (origin :initform 'nil) + (subrefs :initform '() :type list))) + +;; line 95 "locref.nw" +(defun make-layered-location-reference (&key (string "") + (layers '()) (ordnums '()) + (catattr nil) (locclass nil) + (attribute nil) (virtual nil)) + (make-instance 'layered-location-reference + :string string + :layers layers + :ordnums ordnums + :catattr catattr + :locclass locclass + :attribute attribute + :state (if virtual 'locref-state-virtual + 'locref-state-normal))) +;; line 116 "locref.nw" +(defmacro state-normal-p (locref) + `(EQL 'LOCREF-STATE-NORMAL (SLOT-VALUE ,locref 'STATE))) + +(defmacro state-virtual-p (locref) + `(EQL 'LOCREF-STATE-VIRTUAL (SLOT-VALUE ,locref 'STATE))) + +(defmacro state-deleted-p (locref) + `(EQL 'LOCREF-STATE-DELETED (SLOT-VALUE ,locref 'STATE))) + +(defun set-state-normal (locref) + (set-state 'locref-state-normal locref) + locref) + +(defun set-state-virtual (locref) + (set-state 'locref-state-virtual locref) + locref) + +(defun set-state-deleted (locref) + (set-state 'locref-state-deleted locref) + locref) +;; line 139 "locref.nw" +(defmacro rangeattr-open-p (attr) + `(EQL ,attr :RANGEATTR-OPEN)) + +(defmacro rangeattr-close-p (attr) + `(EQL ,attr :RANGEATTR-CLOSE)) + +(defmacro set-rangeattr-open (locref) + `(SETF (SLOT-VALUE ,locref 'RANGEATTR) :RANGEATTR-OPEN)) + +(defmacro set-rangeattr-close (locref) + `(SETF (SLOT-VALUE ,locref 'RANGEATTR) :RANGEATTR-CLOSE)) +;; line 241 "locref.nw" +(defclass category-attribute () + ((name :initarg :name) + (catattr-grp-ordnum :initarg :ordnum) + (sort-ordnum :initform 0) + (processing-ordnum :initform 0) + (last-in-group :initarg :type))) + +(defun make-category-attribute (attr-name) + (make-instance 'category-attribute :name attr-name)) +;; line 174 "locref.nw" +(defclass crossref-location-reference (location-reference) + ((target :initarg :target))) + +(defun create-cross-reference (loccls target attribute) + (make-instance 'crossref-location-reference + :locclass loccls :target target :attribute attribute)) +;; line 201 "locref.nw" +(defmethod build-location-reference ((locclass layered-location-class) + (locref-str string) + (catattr category-attribute) + attribute) + (multiple-value-bind (layers ordnums) + (perform-match locref-str locclass) + (and layers ordnums + (make-layered-location-reference + :locclass locclass :layers layers + :ordnums ordnums :catattr catattr + :attribute attribute :string locref-str)))) +;; line 288 "locref.nw" +(defun locref-class< (locref-1 locref-2) + (declare (inline)) + (< (get-ordnum (get-locclass locref-1)) + (get-ordnum (get-locclass locref-2)))) + +(defun locref-class= (locref-1 locref-2) + (declare (inline)) + (eql (get-locclass locref-1) (get-locclass locref-2))) +;; line 301 "locref.nw" +(defmacro locref-ordnum< (ordnum-list-1 ordnum-list-2) + `(COND + ((EQUAL ,ordnum-list-1 ,ordnum-list-2) NIL) + (T (DO ((REST-1 ,ordnum-list-1 (CDR REST-1)) + (REST-2 ,ordnum-list-2 (CDR REST-2))) + ((OR (ENDP REST-1) (ENDP REST-2) + (/= (FIRST REST-1) (FIRST REST-2))) + (COND ((ENDP REST-1) T) + ((ENDP REST-2) NIL) + (T (< (FIRST REST-1) (FIRST REST-2))))))))) + +(defmacro locref-ordnum= (ordnum-list-1 ordnum-list-2) + `(EQUAL ,ordnum-list-1 ,ordnum-list-2)) +;; line 320 "locref.nw" +#| +FIXME +(defun locref< (locref-1 locref-2) + (cond ((locref-class= locref-1 locref-2) + (locref-ordnum< locref-1 locref-2)) + (t (locref-class< locref-1 locref-2)))) +|# + +(defmethod locref= ((locref-1 crossref-location-reference) + (locref-2 layered-location-reference)) + nil) + +(defmethod locref= ((locref-1 layered-location-reference) + (locref-2 crossref-location-reference)) + nil) + +(defmethod locref= ((locref-1 crossref-location-reference) + (locref-2 crossref-location-reference)) + (and (locref-class= locref-1 locref-2) + (equal (get-target locref-1) (get-target locref-2)))) + +(defmethod locref= ((locref-1 layered-location-reference) + (locref-2 layered-location-reference)) + (and (locref-class= locref-1 locref-2) + (eql (get-catattr locref-1) (get-catattr locref-2)) + (locref-ordnum= (get-ordnums locref-1) (get-ordnums locref-2)) + (eql (get-rangeattr locref-1) (get-rangeattr locref-2)))) + +;; line 391 "locref.nw" +(eval-when (compile load eval) + +;; line 62 "locref.nw" +(export 'location-reference) +;; line 153 "locref.nw" +(export '(layered-location-reference + make-layered-location-reference + get-layers set-layers layers + get-ordnums set-ordnums ordnums + get-subrefs set-subrefs subrefs + get-catattr catattr + get-rangeattr rangeattr + get-locref-string string + get-origin set-origin + state + state-normal-p state-virtual-p state-deleted-p + set-state-normal set-state-virtual set-state-deleted + set-rangeattr-open set-rangeattr-close + rangeattr-open-p rangeattr-close-p)) +;; line 257 "locref.nw" +(export '(category-attribute make-category-attribute + get-name catattr-grp-ordnum + get-catattr-grp-ordnum set-catattr-grp-ordnum + get-sort-ordnum set-sort-ordnum + get-processing-ordnum set-processing-ordnum + get-last-in-group set-last-in-group + get-type set-type + get-markup set-markup)) +;; line 350 "locref.nw" +(export '(locref-class< locref-class= + locref-ordnum< locref-ordnum= + locref=)) +;; line 393 "locref.nw" + ) + +;; line 521 "locclass.nw" +#+:XP +(set-pprint-dispatch 'location-class + #'(lambda (s loccls) + (pprint-logical-block + (s nil :prefix "{" :suffix "}") + (write (get-name loccls) :stream s) + (write-string ":" s) + (write (get-ordnum loccls) :stream s)))) + +#+:XP +(set-pprint-dispatch 'layered-location-class + #'(lambda (s loccls) + (pprint-logical-block + (s nil :prefix "{" :suffix "}") + (write (get-name loccls) :stream s) + (write-string ":" s) + (write (get-ordnum loccls) :stream s) + (mapc #'(lambda (x) + (write-string " " s) + (pprint x s)) + (get-layers loccls))))) + +#+:XP +(set-pprint-dispatch 'loccls-layer + #'(lambda (s layer) + (pprint-logical-block + (s nil :prefix "<" :suffix ">") + (pprint (get-basetype layer) s)))) + +#+:XP +(set-pprint-dispatch 'loccls-separator + #'(lambda (s sep) + (pprint-logical-block + (s nil :prefix "<" :suffix ">") + (write (get-separator sep) :stream s)))) +;; line 406 "locref.nw" +#+:XP +(defun pprint-layered-location-reference (s locref) + (pprint-logical-block + (s nil :prefix "[" :suffix "]") + (cond ((state-normal-p locref) (write-string "Nor:" s)) + ((state-virtual-p locref) (write-string "Vir:" s)) + (t (write-string "Del:" s))) + (cond ((rangeattr-open-p (get-rangeattr locref)) (write-string "OPEN:" s)) + ((rangeattr-close-p (get-rangeattr locref)) (write-string "CLOSE:" s))) + (write-string "\"" s) + (write-string (get-locref-string locref) s) + (write-string "\"=" s) + (write (get-layers locref) :stream s) + (write-string "=" s) + (write (get-ordnums locref) :stream s) + (write-string ";" s) + (pprint-newline :fill s) + (write (get-locclass locref) :stream s) + (write-string ";" s) + (pprint-newline :fill s) + (write (get-catattr locref) :stream s) + (when (get-origin locref) + (write-string "<-" s) + (write (get-catattr (get-origin locref)) :stream s)) + (pprint-newline :fill s) + (write (get-subrefs locref) :stream s) + )) + +#+:XP +(set-pprint-dispatch 'layered-location-reference + #'pprint-layered-location-reference) +;; line 440 "locref.nw" +#+:XP +(defun pprint-crossref-location-reference (s xref) + (pprint-logical-block + (s nil :prefix "[" :suffix "]") + (write (get-locclass xref) :stream s) + (write-string "->" s) + (write (get-target xref) :stream s) + )) + +#+:XP +(set-pprint-dispatch 'crossref-location-reference + #'pprint-crossref-location-reference) +;; line 455 "locref.nw" +#+:XP +(set-pprint-dispatch 'category-attribute + #'(lambda (s catattr) + (write-string "`" s) + (write-string (get-name catattr) s) + (write-string "'" s))) + +;; line 380 "locref.nw" +(defvar *RCS-Identifier* '( +;; line 263 "basetype.nw" +("basetype" . "$Id: basetype.nw,v 1.17 1997/03/26 16:18:47 kehr Exp $") +;; line 513 "locclass.nw" +("locclass" . "$Id: locclass.nw,v 1.21 1997/03/26 16:18:49 kehr Exp $") +;; line 397 "locref.nw" +("locref" . "$Id: locref.nw,v 1.29 1997/03/26 16:18:53 kehr Exp $") +;; line 380 "locref.nw" + )) diff --git a/Build/source/utils/xindy/xindy-2.4/src/markup.lsp b/Build/source/utils/xindy/xindy-2.4/src/markup.lsp new file mode 100644 index 00000000000..c0f696e2a6e --- /dev/null +++ b/Build/source/utils/xindy/xindy-2.4/src/markup.lsp @@ -0,0 +1,1289 @@ +;; line 1154 "markup.nw" +;; $Id: markup.nw,v 1.24 1997/03/26 16:18:58 kehr Exp $ + +(lisp:defpackage "MARKUP") +(lisp:in-package "MARKUP") +(lisp:provide "markup") +#+CLISP (lisp:require "base") +#+CLISP (lisp:require "locref") +#+CLISP (lisp:require "idxstyle") +#+CLISP (lisp:require "index") +#+CLISP (lisp:require "ordrules") +#+CLISP (lisp:require "version") + +(eval-when (compile load eval) + (lisp:use-package "CLOS") + #+(and :XP CLISP) (lisp:use-package "XP") + #+CLISP (setq custom:*suppress-check-redefinition* t) + #-CLISP (lisp:require "base") + #-CLISP (lisp:require "locref") + #-CLISP (lisp:require "idxstyle") + #-CLISP (lisp:require "index") + (lisp:use-package "BASE") + (lisp:use-package "LOCREF") + (lisp:use-package "IDXSTYLE") + (lisp:use-package "INDEX")) + +;; line 1222 "markup.nw" +;; $Id: markup.nw,v 1.24 1997/03/26 16:18:58 kehr Exp $ + +;; line 71 "markup.nw" +(defparameter *markup-output-stream* *standard-output*) +(defparameter *markup-verbose-mode* nil) +(defparameter *markup-verbose-open* "<") +(defparameter *markup-verbose-close* ">") +(defparameter *markup-indentation* 2) +(defparameter *markup-indent-level* 0) +(defparameter *empty-markup* "") + +(defvar *markup-percentage-list*) +(defvar *current-number*) + +(defun do-markup-indent () + (incf *markup-indent-level* *markup-indentation*)) +(defun do-markup-outdent () + (decf *markup-indent-level* *markup-indentation*)) +;; line 102 "markup.nw" +(defun do-markup-string (str) + (declare (inline)) + (write-string str *markup-output-stream*)) +;; line 111 "markup.nw" +(defun do-markup-default (str &optional arg1 arg2 arg3) + (when *markup-verbose-mode* + (loop for x from 1 to *markup-indent-level* + do (write-string " " *markup-output-stream*)) + (do-markup-string *markup-verbose-open*) + (do-markup-string str) + (when arg1 + (format *markup-output-stream* " [~S]" arg1) + (when arg2 + (format *markup-output-stream* " [~S]" arg2) + (when arg3 + (format *markup-output-stream* " [~S]" arg3) + ))) + (do-markup-string *markup-verbose-close*) + (terpri *markup-output-stream*) + )) +;; line 138 "markup.nw" +(defmacro do-markup-list (some-list + &key + identifier counter + elt-body sep-body + open-body close-body) + `(PROGN + ,(when open-body `,open-body) + (LET ,(if counter + `((LIST-END (CAR (LAST ,some-list))) + (COUNTER ,counter)) + `((LIST-END (CAR (LAST ,some-list))))) + (DO ((SLIST ,some-list (CDR SLIST))) + ((ENDP SLIST)) + (LET ((,identifier (CAR SLIST))) + ,elt-body + ,(if sep-body + `(UNLESS (EQL ,identifier LIST-END) + ,sep-body))))) + ,(when close-body close-body))) +;; line 162 "markup.nw" +#| +(macroexpand '(markup-list '(1 2 3) :identifier FOO + :open-body (print "open") + :close-body (print "close") + :elt-body (print FOO) + :sep-body (print ","))) + +expands to + +(PROGN (PRINT "open") + (LET ((LIST-END (CAR (LAST '(1 2 3))))) + (DO ((SLIST '(1 2 3) (CDR SLIST))) ((ENDP SLIST)) + (LET ((FOO (CAR SLIST))) (PRINT FOO) + (UNLESS (EQL FOO LIST-END) (PRINT ",")) + ) ) ) + (PRINT "close") +) ; +T +|# +;; line 193 "markup.nw" +(defmacro define-list-environment-methods (name + signature + &key open close sep declare body) + (let ((name (stringify name))) + `(EVAL-WHEN (COMPILE LOAD EVAL) + (HANDLER-BIND ((WARNING #'MUFFLE-WARNING)) + (CL:DEFMETHOD + ,(intern (string-upcase (concatenate 'string name "-open")) + 'markup) + ,signature ,@declare ,@open ,@body) + (CL:DEFMETHOD + ,(intern (string-upcase (concatenate 'string name "-close")) + 'markup) + ,signature ,@declare ,@close ,@body) + (CL:DEFMETHOD + ,(intern (string-upcase (concatenate 'string name "-sep")) + 'markup) + ,signature ,@declare ,@sep ,@body))))) +;; line 214 "markup.nw" +(defmacro define-environment-methods (name + signature + &key open close declare body) + (let ((name (stringify name))) + `(EVAL-WHEN (COMPILE LOAD EVAL) + (HANDLER-BIND ((WARNING #'MUFFLE-WARNING)) + (CL:DEFMETHOD + ,(intern (string-upcase (concatenate 'string name "-open")) + 'markup) + ,signature ,@declare ,@open ,@body) + (CL:DEFMETHOD + ,(intern (string-upcase (concatenate 'string name "-close")) + 'markup) + ,signature ,@declare ,@close ,@body))))) + +(defmacro define-method (name + signature + &key declare body) + (let ((name (stringify name))) + `(EVAL-WHEN (COMPILE LOAD EVAL) + (HANDLER-BIND ((WARNING #'MUFFLE-WARNING)) + (CL:DEFMETHOD + ,(intern (string-upcase name) 'markup) + ,signature ,@declare ,@body))))) +;; line 326 "markup.nw" +(defmethod do-markup-index ((idx base-index)) + (setq *current-number* 0) + (setq *markup-percentage-list* index:*percentage-list*) + (do-markup-index-open idx) + (do-markup-list (get-entries idx) + :identifier LETTER-GRP + :open-body (do-markup-letter-group-list-open) + :elt-body (do-markup-letter-group LETTER-GRP) + :sep-body (do-markup-letter-group-list-sep) + :close-body (do-markup-letter-group-list-close)) + (index:print-rest-of-percentages *markup-percentage-list*) + (do-markup-index-close idx)) + +(define-environment-methods do-markup-index ((idx base-index)) + :open ((do-markup-default "INDEX:OPEN") + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "INDEX:CLOSE"))) +;; line 351 "markup.nw" +(defmacro markup-index (&whole whole &rest args) + (destructuring-switch-bind (&key + open close hierdepth + &switch + tree flat) + args + (let (hierdepth-cmd) + (when (or hierdepth tree flat) + (cond + ((and tree flat) + (error "you can't specify :tree and :flat simultaneously in ~%~S~%" + whole)) + ((and hierdepth (or tree flat)) + (error "you can't specify :hierdepth with :tree or :flat simultaneously in ~%~S~%" + whole)) + (flat (setq hierdepth-cmd + `(SET-HIERDEPTH 0 *INDEX*)));; no tree-structure + ;; MOST-POSITIVE-FIXNUM means make all trees + (tree (setq hierdepth-cmd + `(SET-HIERDEPTH MOST-POSITIVE-FIXNUM *INDEX*))) + (hierdepth + (when (not (numberp hierdepth)) + (error "~S is not a number in ~S~%" whole)) + (setq hierdepth-cmd + `(SET-HIERDEPTH ,hierdepth *INDEX*)))) + `(LET () + (markup::define-environment-methods + DO-MARKUP-INDEX ((idx index:base-index)) + :declare ((declare (ignore idx))) + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close)))) + ,hierdepth-cmd))))) +;; line 390 "markup.nw" +(define-list-environment-methods do-markup-letter-group-list () + :open ((do-markup-default "LETTER-GROUP-LIST:OPEN") + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "LETTER-GROUP-LIST:CLOSE")) + :sep ((do-markup-default "LETTER-GROUP-LIST:SEP"))) +;; line 409 "markup.nw" +(defmethod do-markup-letter-group ((letter-grp letter-group)) + (let ((group-definition (get-group-definition letter-grp))) + (do-markup-letter-group-open group-definition) + (do-markup-letter-group-head-open group-definition) + (do-markup-letter-group-head group-definition) + (do-markup-letter-group-head-close group-definition) + (do-markup-list (get-members letter-grp) + :identifier IDXENT #| the identifier to use in the expansion |# + :open-body (do-markup-indexentry-list-open 0 + #|initial depth:=0|#) + :elt-body (do-markup-indexentry IDXENT 0) + :sep-body (do-markup-indexentry-list-sep 0) + :close-body (do-markup-indexentry-list-close 0)) + (do-markup-letter-group-close group-definition))) + +(define-environment-methods do-markup-letter-group + ((group letter-group-definition)) + :open ((do-markup-default "LETTER-GROUP:OPEN" (get-name group)) + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "LETTER-GROUP:CLOSE" (get-name group)))) + +(define-environment-methods do-markup-letter-group-head + ((group letter-group-definition)) + :open ((do-markup-default "LETTER-GROUP-HEAD:OPEN" (get-name group)) + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "LETTER-GROUP-HEAD:CLOSE" (get-name group)))) + +(define-method do-markup-letter-group-head ((group letter-group-definition)) + :body ((do-markup-default "LETTER-GROUP-HEAD" (get-name group)))) +;; line 503 "markup.nw" +(define-list-environment-methods do-markup-indexentry-list ((depth number)) + :open ((do-markup-default "INDEXENTRY-LIST:OPEN" depth) + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "INDEXENTRY-LIST:CLOSE" depth)) + :sep ((do-markup-default "INDEXENTRY-LIST:SEP" depth))) +;; line 525 "markup.nw" +(defmethod do-markup-indexentry ((idxent index-entry) + (depth number)) + (when (>= (incf *current-number*) (caar *markup-percentage-list*)) + (index:print-percent (pop *markup-percentage-list*))) + + (do-markup-indexentry-open depth) + + (let ((print-key (get-print-key idxent))) + (do-markup-list (merge-print-and-main-key print-key (get-main-key idxent)) + :identifier KEYWORD + :open-body (do-markup-keyword-list-open depth) + :elt-body (do-markup-keyword KEYWORD depth) + :sep-body (do-markup-keyword-list-sep depth) + :close-body (do-markup-keyword-list-close depth))) + + (let ((locrefs (get-locrefs idxent))) + (unless (endp locrefs) + (do-markup-list locrefs + :identifier LOCCLS-GRP + :open-body (do-markup-locclass-list-open) + :elt-body (do-markup-locclass LOCCLS-GRP) + :sep-body (do-markup-locclass-list-sep) + :close-body (do-markup-locclass-list-close)))) + + (let ((subentries (get-subentries idxent))) + (unless (endp subentries) + (let ((new-depth (1+ depth))) + (do-markup-list subentries + :identifier IDXENT + :open-body (do-markup-indexentry-list-open new-depth) + :elt-body (do-markup-indexentry IDXENT new-depth) + :sep-body (do-markup-indexentry-list-sep new-depth) + :close-body (do-markup-indexentry-list-close new-depth))))) + + (do-markup-indexentry-close depth)) + +(defun merge-print-and-main-key (print-key main-key) + ;;(info "~&(merge-print-and-main-key ~S ~S)" print-key main-key) + (if print-key + (mapcar #'(lambda (print main) + (or print main)) + print-key main-key) + main-key)) +;; line 571 "markup.nw" +(define-environment-methods do-markup-indexentry ((depth number)) + :open ((do-markup-default "INDEXENTRY:OPEN" depth) + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "INDEXENTRY:CLOSE" depth))) +;; line 595 "markup.nw" +(define-list-environment-methods do-markup-keyword-list ((depth number)) + :open ((do-markup-default "KEYWORD-LIST:OPEN" depth) + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "KEYWORD-LIST:CLOSE" depth)) + :sep ((do-markup-default "KEYWORD-LIST:SEP" depth))) +;; line 617 "markup.nw" +(defmethod do-markup-keyword (keyword (depth number)) + (do-markup-keyword-open depth) + (do-markup-string keyword) + (do-markup-keyword-close depth)) +;; line 624 "markup.nw" +(define-environment-methods do-markup-keyword ((depth number)) + :open ((do-markup-default "KEYWORD:OPEN" depth) + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "KEYWORD:CLOSE" depth))) +;; line 654 "markup.nw" +(define-list-environment-methods do-markup-locclass-list () + :open ((do-markup-default "LOCCLASS-LIST:OPEN") + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "LOCCLASS-LIST:CLOSE")) + :sep ((do-markup-default "LOCCLASS-LIST:SEP"))) +;; line 677 "markup.nw" +(defmethod do-markup-locclass ((locref-cls-grp locref-class-group)) + (let ((locclass (get-locclass locref-cls-grp))) + (do-markup-locref-class-open locclass) + + (do-markup-list (get-members locref-cls-grp) + :identifier ATTRIBUTE-GRP + :open-body (do-markup-attribute-group-list-open) + :elt-body (do-markup-attribute-group ATTRIBUTE-GRP locclass) + :sep-body (do-markup-attribute-group-list-sep) + :close-body (do-markup-attribute-group-list-close)) + + (do-markup-locref-class-close locclass))) + +(define-environment-methods do-markup-locref-class + ((locrefcls layered-location-class)) + :open ((do-markup-default "LOCREF-CLASS:OPEN" (get-name locrefcls)) + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "LOCREF-CLASS:CLOSE" (get-name locrefcls)))) +;; line 1044 "markup.nw" +(defmethod do-markup-locclass ((xref-cls-grp crossref-class-group)) + (let ((xrefclass (get-locclass xref-cls-grp))) + + (do-markup-list (get-members xref-cls-grp) + :identifier XREF + :open-body (do-markup-crossref-list-open xrefclass) + :elt-body (do-markup-crossref XREF) + :sep-body (do-markup-crossref-list-sep xrefclass) + :close-body (do-markup-crossref-list-close xrefclass)))) + +(define-list-environment-methods do-markup-crossref-list + ((xrefclass crossref-location-class)) + :open ((do-markup-default "CROSSREF-LIST:OPEN" (get-name xrefclass)) + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "CROSSREF-LIST:CLOSE" (get-name xrefclass))) + :sep ((do-markup-default "CROSSREF-LIST:SEP" (get-name xrefclass)))) +;; line 1080 "markup.nw" +(defmethod do-markup-crossref ((xref crossref-location-reference)) + (let ((xrefclass (get-locclass xref))) + + (do-markup-list (get-target xref) + :identifier XREF-LAYER + :open-body (do-markup-crossref-layer-list-open xrefclass) + :elt-body (do-markup-crossref-layer XREF-LAYER xrefclass) + :sep-body (do-markup-crossref-layer-list-sep xrefclass) + :close-body (do-markup-crossref-layer-list-close xrefclass)))) + +(define-list-environment-methods do-markup-crossref-layer-list + ((xref-class crossref-location-class)) + :open ((do-markup-default "CROSSREF-LAYER-LIST:OPEN" + (get-name xref-class)) + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "CROSSREF-LAYER-LIST:CLOSE" + (get-name xref-class))) + :sep ((do-markup-default "CROSSREF-LAYER-LIST:SEP" + (get-name xref-class)))) +;; line 1119 "markup.nw" +(defmethod do-markup-crossref-layer (xref-layer + (xref-class crossref-location-class)) + (do-markup-crossref-layer-open xref-class) + (do-markup-string xref-layer) + (do-markup-crossref-layer-close xref-class)) + +(define-environment-methods do-markup-crossref-layer + ((xref-class crossref-location-class)) + :open ((do-markup-default "CROSSREF-LAYER:OPEN" (get-name xref-class)) + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "CROSSREF-LAYER:CLOSE" (get-name xref-class)))) +;; line 718 "markup.nw" +(define-list-environment-methods do-markup-attribute-group-list () + :open ((do-markup-default "ATTRIBUTE-GROUP-LIST:OPEN") + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "ATTRIBUTE-GROUP-LIST:CLOSE")) + :sep ((do-markup-default "ATTRIBUTE-GROUP-LIST:SEP"))) +;; line 737 "markup.nw" +(defmethod do-markup-attribute-group ((attribute-group category-attribute-group) + (loccls layered-location-class)) + (let ((ordnum (get-ordnum attribute-group))) + (do-markup-attribute-group-open ordnum) + + (do-markup-list (get-members attribute-group) + :identifier LOCREF + :open-body (do-markup-locref-list-open loccls 0) + :elt-body (do-markup-locref LOCREF loccls 0) + :sep-body (do-markup-locref-list-sep loccls 0) + :close-body (do-markup-locref-list-close loccls 0)) + + (do-markup-attribute-group-close ordnum))) + +(define-environment-methods do-markup-attribute-group ((ordnum number)) + :open ((do-markup-default "ATTRIBUTE-GROUP:OPEN" ordnum) + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "ATTRIBUTE-GROUP:CLOSE" ordnum))) +;; line 776 "markup.nw" +(define-list-environment-methods do-markup-locref-list + ((loccls layered-location-class) (depth number)) + :open ((do-markup-default "LOCREF-LIST:OPEN" (get-name loccls) depth) + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "LOCREF-LIST:CLOSE" (get-name loccls) depth)) + :sep ((do-markup-default "LOCREF-LIST:SEP" (get-name loccls) depth))) +;; line 808 "markup.nw" +(defmethod do-markup-locref ((locref location-reference) + (loccls layered-location-class) + (depth number)) + #+ASSERT! (assert! (and (typep locref 'layered-location-reference) + (typep depth 'number))) + (let ((attr (get-catattr locref)) + (subrefs (get-subrefs locref)) + (new-depth (1+ depth))) + + (do-markup-locref-open attr loccls depth) + + (cond + (subrefs + (let ((layer 0)) + (do-markup-list (get-layers locref) + :identifier LOCREF-LAYER + :open-body (do-markup-locref-layer-list-open loccls depth) + :elt-body (do-markup-locref-layer LOCREF-LAYER loccls depth + (prog1 layer + (incf layer))) + :sep-body (do-markup-locref-layer-list-sep loccls depth) + :close-body (do-markup-locref-layer-list-close loccls depth))) + + (do-markup-list subrefs + :identifier LOCREF + :open-body (do-markup-locref-list-open loccls new-depth) + :elt-body (do-markup-locref LOCREF loccls new-depth) + :sep-body (do-markup-locref-list-sep loccls new-depth) + :close-body (do-markup-locref-list-close loccls new-depth))) + + ((= 0 depth) + (do-markup-string (get-locref-string locref))) + + (t (let ((layer 0)) + (do-markup-list (get-layers locref) + :identifier LOCREF-LAYER + :open-body (do-markup-locref-layer-list-open loccls depth) + :elt-body (do-markup-locref-layer LOCREF-LAYER loccls depth + (prog1 layer + (incf layer))) + :sep-body (do-markup-locref-layer-list-sep loccls depth) + :close-body (do-markup-locref-layer-list-close loccls depth))))) + + (do-markup-locref-close attr loccls depth))) +;; line 855 "markup.nw" +(define-list-environment-methods do-markup-locref-layer-list + ((loccls layered-location-class) (depth number)) + :open ((do-markup-default "LOCREF-LAYER-LIST:OPEN" (get-name loccls) depth) + (do-markup-indent)) + :sep ((do-markup-default "LOCREF-LAYER-LIST:SEP" (get-name loccls) depth)) + :close ((do-markup-outdent) + (do-markup-default "LOCREF-LAYER-LIST:CLOSE" (get-name loccls) depth))) +;; line 883 "markup.nw" +(defun do-markup-locref-layer (locref-layer loccls depth layer) + (do-markup-locref-layer-open loccls depth layer) + (do-markup-string locref-layer) + (do-markup-locref-layer-close loccls depth layer)) + +(define-environment-methods do-markup-locref-layer + ((locref-class layered-location-class) (depth number) (layer number)) + :open ((do-markup-default "LOCREF-LAYER:OPEN" + (get-name locref-class) depth layer) + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "LOCREF-LAYER:CLOSE" + (get-name locref-class) depth layer))) +;; line 918 "markup.nw" +(define-environment-methods do-markup-locref ((attr category-attribute) + (loccls layered-location-class) + (depth number)) + :open ((do-markup-default "LOCREF:OPEN" + (get-name attr) (get-name loccls) depth) + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "LOCREF:CLOSE" + (get-name attr) (get-name loccls) depth))) +;; line 955 "markup.nw" +(defmethod do-markup-locref ((range location-range) + (loccls layered-location-class) + (depth number)) + (let ((length (get-length range))) + (do-markup-range-open loccls length) + (do-markup-locref (get-first range) loccls depth) + (do-markup-range-sep loccls length) + (when (markup-range-print-end-p loccls length) + (do-markup-locref (get-last range) loccls depth)) + (do-markup-range-close loccls length))) + +(define-list-environment-methods do-markup-range + ((loccls layered-location-class) (length number)) + :open ((do-markup-default "RANGE:OPEN" (get-name loccls) length) + (do-markup-indent)) + :close ((do-markup-outdent) + (do-markup-default "RANGE:CLOSE" (get-name loccls) length)) + :sep ((do-markup-default "RANGE:SEP" (get-name loccls) length))) + +(defmethod markup-range-print-end-p ((loccls layered-location-class) + (length number)) + t) +;; line 304 "markup.nw" +(defmacro markup-trace (&rest args) + (destructuring-switch-bind (&key + (open *markup-verbose-open*) + (close *markup-verbose-close*) + &switch + on) + args + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 312 "markup.nw" + (t `(LET () + (SETQ *markup-verbose-open* ,open) + (SETQ *markup-verbose-close* ,close) + ,(when on `(SETQ *markup-verbose-mode* t))))))) +;; line 399 "markup.nw" +(defmacro markup-letter-group-list (&key open close sep) + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 260 "markup.nw" +((and sep (not (stringp sep))) + (nraw "parameter `~S' is not a string! (ignored)~%" sep)) +;; line 401 "markup.nw" + (t `(markup::define-list-environment-methods + DO-MARKUP-LETTER-GROUP-LIST () + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))) + :sep ,(when sep `((do-markup-string ,sep))))))) +;; line 443 "markup.nw" +(defmacro markup-letter-group (&whole whole &rest args) + (destructuring-switch-bind (&key + open close group + open-head close-head + &switch + upcase downcase capitalize) + args + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 451 "markup.nw" + +;; line 252 "markup.nw" +((and open-head (not (stringp open-head))) + (nraw "parameter `~S' is not a string! (ignored)~%" open-head)) +((and close-head (not (stringp close-head))) + (nraw "parameter `~S' is not a string! (ignored)~%" close-head)) +;; line 452 "markup.nw" + +;; line 275 "markup.nw" +((and group (progn + (setq group (stringify group)) + (not (lookup-letter-group-definition *indexstyle* group)))) + (nraw "parameter `~S' is not a valid letter-group! (ignored)~%" group)) +;; line 453 "markup.nw" + ((or (and upcase downcase) + (and upcase capitalize) + (and downcase capitalize)) + (error "more than one modifier in~%~S" whole)) + (t `(LET () + (markup::define-environment-methods + DO-MARKUP-LETTER-GROUP + (,(if group + `(lg-def (EQL ',(lookup-letter-group-definition + *indexstyle* group))) + '(lg-def letter-group-definition))) + :declare ((declare (ignore lg-def))) + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close)))) + (markup::define-environment-methods + DO-MARKUP-LETTER-GROUP-HEAD + (,(if group + `(lg-def (EQL ',(lookup-letter-group-definition + *indexstyle* group))) + '(lg-def letter-group-definition))) + :declare ((declare (ignore lg-def))) + :open ,(when open-head `((do-markup-string ,open-head))) + :close ,(when close-head `((do-markup-string ,close-head)))) + ,(when (or open-head close-head) + `(markup::define-method + DO-MARKUP-LETTER-GROUP-HEAD + (,(if group + `(lg-def (EQL ',(lookup-letter-group-definition + *indexstyle* group))) + '(lg-def letter-group-definition))) + :body ((do-markup-string + ,(cond (upcase `(string-upcase + (get-name lg-def))) + (downcase `(string-downcase + (get-name lg-def))) + (capitalize `(string-capitalize + (get-name lg-def))) + (t `(get-name lg-def)))))))))))) +;; line 512 "markup.nw" +(defmacro markup-indexentry-list (&key open close sep depth) + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 260 "markup.nw" +((and sep (not (stringp sep))) + (nraw "parameter `~S' is not a string! (ignored)~%" sep)) +;; line 514 "markup.nw" + +;; line 265 "markup.nw" +((and depth (not (integerp depth))) + (nraw "parameter `~S' is not a number! (ignored)~%" depth)) +;; line 515 "markup.nw" + (t `(markup::define-list-environment-methods + DO-MARKUP-INDEXENTRY-LIST + (,(if depth `(depth (EQL ,depth)) '(depth number))) + :declare ((declare (ignore depth))) + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))) + :sep ,(when sep `((do-markup-string ,sep))))))) +;; line 579 "markup.nw" +(defmacro markup-indexentry (&key open close depth) + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 581 "markup.nw" + +;; line 265 "markup.nw" +((and depth (not (integerp depth))) + (nraw "parameter `~S' is not a number! (ignored)~%" depth)) +;; line 582 "markup.nw" + (t `(markup::define-environment-methods + DO-MARKUP-INDEXENTRY + (,(if depth `(depth (EQL ,depth)) '(depth number))) + :declare ((declare (ignore depth))) + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))))))) +;; line 604 "markup.nw" +(defmacro markup-keyword-list (&key open close sep depth) + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 260 "markup.nw" +((and sep (not (stringp sep))) + (nraw "parameter `~S' is not a string! (ignored)~%" sep)) +;; line 606 "markup.nw" + +;; line 265 "markup.nw" +((and depth (not (integerp depth))) + (nraw "parameter `~S' is not a number! (ignored)~%" depth)) +;; line 607 "markup.nw" + (t `(markup::define-list-environment-methods + DO-MARKUP-KEYWORD-LIST + (,(if depth `(depth (EQL ,depth)) '(depth number))) + :declare ((declare (ignore depth))) + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))) + :sep ,(when sep `((do-markup-string ,sep))))))) +;; line 632 "markup.nw" +(defmacro markup-keyword (&key open close depth) + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 634 "markup.nw" + +;; line 265 "markup.nw" +((and depth (not (integerp depth))) + (nraw "parameter `~S' is not a number! (ignored)~%" depth)) +;; line 635 "markup.nw" + (t `(markup::define-environment-methods + DO-MARKUP-KEYWORD + (,(if depth `(depth (EQL ,depth)) '(depth number))) + :declare ((declare (ignore depth))) + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))))))) +;; line 663 "markup.nw" +(defmacro markup-locclass-list (&key open close sep) + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 260 "markup.nw" +((and sep (not (stringp sep))) + (nraw "parameter `~S' is not a string! (ignored)~%" sep)) +;; line 665 "markup.nw" + (t `(markup::define-list-environment-methods + DO-MARKUP-LOCCLASS-LIST () + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))) + :sep ,(when sep `((do-markup-string ,sep))))))) +;; line 699 "markup.nw" +(defmacro markup-locref-class (&key open close class) + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 701 "markup.nw" + +;; line 282 "markup.nw" +((and class (progn (setq class (stringify class)) + (not (lookup-locref-class *indexstyle* class)))) + (nraw "parameter `~S' is not a location-reference class! (ignored)~%" class)) +;; line 702 "markup.nw" + (t `(markup::define-list-environment-methods + DO-MARKUP-LOCREF-CLASS + (,(if class + `(locrefcls (EQL ',(cdr (lookup-locref-class + *indexstyle* class)))) + '(locrefcls layered-location-class))) + :declare ((declare (ignore locrefcls))) + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))))))) +;; line 727 "markup.nw" +(defmacro markup-attribute-group-list (&key open close sep) + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 260 "markup.nw" +((and sep (not (stringp sep))) + (nraw "parameter `~S' is not a string! (ignored)~%" sep)) +;; line 729 "markup.nw" + (t `(markup::define-list-environment-methods + DO-MARKUP-ATTRIBUTE-GROUP-LIST () + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))) + :sep ,(when sep `((do-markup-string ,sep))))))) +;; line 759 "markup.nw" +(defmacro markup-attribute-group (&key open close group) + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 761 "markup.nw" + +;; line 275 "markup.nw" +((and group (progn + (setq group (stringify group)) + (not (lookup-letter-group-definition *indexstyle* group)))) + (nraw "parameter `~S' is not a valid letter-group! (ignored)~%" group)) +;; line 762 "markup.nw" + (t `(markup::define-environment-methods + DO-MARKUP-ATTRIBUTE-GROUP + (,(if group + `(ordnum (EQL ,group)) + '(ordnum number))) + :declare ((declare (ignore ordnum))) + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))))))) +;; line 786 "markup.nw" +(defmacro markup-locref-list (&key open close sep class depth) + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 260 "markup.nw" +((and sep (not (stringp sep))) + (nraw "parameter `~S' is not a string! (ignored)~%" sep)) +;; line 788 "markup.nw" + +;; line 265 "markup.nw" +((and depth (not (integerp depth))) + (nraw "parameter `~S' is not a number! (ignored)~%" depth)) +;; line 789 "markup.nw" + +;; line 282 "markup.nw" +((and class (progn (setq class (stringify class)) + (not (lookup-locref-class *indexstyle* class)))) + (nraw "parameter `~S' is not a location-reference class! (ignored)~%" class)) +;; line 790 "markup.nw" + (t `(markup::define-list-environment-methods + DO-MARKUP-LOCREF-LIST + (,(if class + `(locrefcls (EQL ',(cdr (lookup-locref-class + *indexstyle* class)))) + '(locrefcls layered-location-class)) + ,(if depth `(depth (EQL ,depth)) '(depth number))) + :declare ((declare (ignore locrefcls depth))) + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))) + :sep ,(when sep `((do-markup-string ,sep))))))) +;; line 865 "markup.nw" +(defmacro markup-locref-layer-list (&key open close sep class depth) + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 260 "markup.nw" +((and sep (not (stringp sep))) + (nraw "parameter `~S' is not a string! (ignored)~%" sep)) +;; line 867 "markup.nw" + +;; line 265 "markup.nw" +((and depth (not (integerp depth))) + (nraw "parameter `~S' is not a number! (ignored)~%" depth)) +;; line 868 "markup.nw" + +;; line 282 "markup.nw" +((and class (progn (setq class (stringify class)) + (not (lookup-locref-class *indexstyle* class)))) + (nraw "parameter `~S' is not a location-reference class! (ignored)~%" class)) +;; line 869 "markup.nw" + (t `(markup::define-list-environment-methods + DO-MARKUP-LOCREF-LAYER-LIST + (,(if class + `(locrefcls (EQL ',(cdr (lookup-locref-class + *indexstyle* class)))) + '(locrefcls layered-location-class)) + ,(if depth `(depth (EQL ,depth)) '(depth number))) + :declare ((declare (ignore locrefcls depth))) + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))) + :sep ,(when sep `((do-markup-string ,sep))))))) +;; line 899 "markup.nw" +(defmacro markup-locref-layer (&key class open close depth layer) + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 901 "markup.nw" + +;; line 265 "markup.nw" +((and depth (not (integerp depth))) + (nraw "parameter `~S' is not a number! (ignored)~%" depth)) +;; line 902 "markup.nw" + +;; line 270 "markup.nw" +((and layer (not (integerp layer))) + (nraw "parameter `~S' is not a number! (ignored)~%" layer)) +;; line 903 "markup.nw" + +;; line 282 "markup.nw" +((and class (progn (setq class (stringify class)) + (not (lookup-locref-class *indexstyle* class)))) + (nraw "parameter `~S' is not a location-reference class! (ignored)~%" class)) +;; line 904 "markup.nw" + (t `(markup::define-environment-methods + DO-MARKUP-LOCREF-LAYER + (,(if class + `(locrefcls (EQL ',(cdr (lookup-locref-class + *indexstyle* class)))) + '(locrefcls layered-location-class)) + ,(if depth `(depth (EQL ,depth)) '(depth number)) + ,(if layer `(layer (EQL ,layer)) '(layer number))) + :declare ((declare (ignore depth layer))) + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))))))) +;; line 930 "markup.nw" +(defmacro markup-locref (&key open close class attr depth) + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 932 "markup.nw" + +;; line 294 "markup.nw" +((and attr (progn (setq attr (stringify attr)) + (not (lookup-catattr *indexstyle* attr)))) + (nraw "parameter `~S' is not an attribute! (ignored)~%" attr)) +;; line 933 "markup.nw" + +;; line 265 "markup.nw" +((and depth (not (integerp depth))) + (nraw "parameter `~S' is not a number! (ignored)~%" depth)) +;; line 934 "markup.nw" + +;; line 282 "markup.nw" +((and class (progn (setq class (stringify class)) + (not (lookup-locref-class *indexstyle* class)))) + (nraw "parameter `~S' is not a location-reference class! (ignored)~%" class)) +;; line 935 "markup.nw" + (t `(markup::define-environment-methods + DO-MARKUP-LOCREF + (,(if attr + `(attr (EQL ',(lookup-catattr *indexstyle* attr))) + '(attr category-attribute)) + ,(if class + `(locrefcls (EQL ',(cdr (lookup-locref-class + *indexstyle* class)))) + '(locrefcls layered-location-class)) + ,(if depth `(depth (EQL ,depth)) '(depth number))) + :declare ((declare (ignore attr locrefcls depth))) + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))))))) +;; line 1002 "markup.nw" +(defmacro markup-range (&whole whole &rest args) + (destructuring-switch-bind (&key + open close sep class length + &switch ignore-end) + args + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 260 "markup.nw" +((and sep (not (stringp sep))) + (nraw "parameter `~S' is not a string! (ignored)~%" sep)) +;; line 1008 "markup.nw" + +;; line 282 "markup.nw" +((and class (progn (setq class (stringify class)) + (not (lookup-locref-class *indexstyle* class)))) + (nraw "parameter `~S' is not a location-reference class! (ignored)~%" class)) +;; line 1009 "markup.nw" + ((and length (not (numberp length))) + (nraw "parameter `~S' is not a number! (ignored)~%" length)) + (t `(let () + (markup::define-list-environment-methods + DO-MARKUP-RANGE + (,(if class + `(locrefcls (EQL ',(cdr (lookup-locref-class + *indexstyle* class)))) + '(locrefcls layered-location-class)) + ,(if length + `(length (EQL ,length)) + '(length number))) + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))) + :sep ,(when sep `((do-markup-string ,sep)))) + (define-method markup::MARKUP-RANGE-PRINT-END-P + (,(if class + `(locrefcls (EQL ',(cdr (lookup-locref-class + *indexstyle* class)))) + '(locrefcls layered-location-class)) + ,(if length + `(length (EQL ,length)) + '(length number))) + :declare ((declare (ignore locrefcls length))) + :body (,(not ignore-end)))))))) +;; line 1064 "markup.nw" +(defmacro markup-crossref-list (&key open sep close class) + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 260 "markup.nw" +((and sep (not (stringp sep))) + (nraw "parameter `~S' is not a string! (ignored)~%" sep)) +;; line 1066 "markup.nw" + +;; line 288 "markup.nw" +((and class (progn (setq class (stringify class)) + (not (lookup-crossref-class *indexstyle* class)))) + (nraw "parameter `~S' is not a cross-reference class! (ignored)~%" class)) +;; line 1067 "markup.nw" + (t `(markup::define-list-environment-methods + DO-MARKUP-CROSSREF-LIST + (,(if class + `(xrefcls (EQL ',(cdr (lookup-crossref-class *indexstyle* + class)))) + '(xrefcls crossref-location-class))) + :declare ((declare (ignore xrefcls))) + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))) + :sep ,(when sep `((do-markup-string ,sep))))))) +;; line 1103 "markup.nw" +(defmacro markup-crossref-layer-list (&key open sep close class) + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 260 "markup.nw" +((and sep (not (stringp sep))) + (nraw "parameter `~S' is not a string! (ignored)~%" sep)) +;; line 1105 "markup.nw" + +;; line 288 "markup.nw" +((and class (progn (setq class (stringify class)) + (not (lookup-crossref-class *indexstyle* class)))) + (nraw "parameter `~S' is not a cross-reference class! (ignored)~%" class)) +;; line 1106 "markup.nw" + (t `(markup::define-list-environment-methods + DO-MARKUP-CROSSREF-LAYER-LIST + (,(if class + `(xrefcls (EQL ',(cdr (lookup-crossref-class *indexstyle* + class)))) + '(xrefcls crossref-location-class))) + :declare ((declare (ignore xrefcls))) + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))) + :sep ,(when sep `((do-markup-string ,sep))))))) +;; line 1134 "markup.nw" +(defmacro markup-crossref-layer (&key open close class) + (cond +;; line 245 "markup.nw" +((and open (not (stringp open))) + (nraw "parameter `~S' is not a string! (ignored)~%" open)) +((and close (not (stringp close))) + (nraw "parameter `~S' is not a string! (ignored)~%" close)) +;; line 1136 "markup.nw" + +;; line 288 "markup.nw" +((and class (progn (setq class (stringify class)) + (not (lookup-crossref-class *indexstyle* class)))) + (nraw "parameter `~S' is not a cross-reference class! (ignored)~%" class)) +;; line 1137 "markup.nw" + (t `(markup::define-list-environment-methods + DO-MARKUP-CROSSREF-LAYER + (,(if class + `(xrefcls (EQL ',(cdr (lookup-crossref-class *indexstyle* + class)))) + '(xrefcls crossref-location-class))) + :declare ((declare (ignore xrefcls))) + :open ,(when open `((do-markup-string ,open))) + :close ,(when close `((do-markup-string ,close))))))) +;; line 1188 "markup.nw" +(eval-when (compile load eval) + (defparameter *markup-user-interface-definitions* + '(*markup-verbose-mode* + *markup-verbose-open* + *markup-verbose-close* + markup-crossref-layer + markup-crossref-layer-list + markup-crossref-list + markup-index + markup-letter-group + markup-letter-group-list + markup-indexentry + markup-indexentry-list + markup-keyword + markup-keyword-list + markup-locclass-list + markup-locref-class + markup-attribute-group-list + markup-attribute-group + markup-locref-list + markup-locref + markup-locref-layer-list + markup-locref-layer + markup-range + markup-trace + ))) + +;; line 1238 "markup.nw" +(eval-when (compile load eval) + +;; line 89 "markup.nw" +(export '(*markup-output-stream* + *markup-verbose-mode* + *markup-verbose-open* + *markup-verbose-close* + *indexstyle-readtable*)) +;; line 347 "markup.nw" +(export '(do-markup-index)) +;; line 1217 "markup.nw" +(export '*markup-user-interface-definitions*) +(export *markup-user-interface-definitions*) +;; line 1240 "markup.nw" + ) + +;; line 1178 "markup.nw" +(defvar *RCS-Identifier* '( +;; line 1244 "markup.nw" +("markup" . "$Id: markup.nw,v 1.24 1997/03/26 16:18:58 kehr Exp $") +;; line 236 "startup.nw" +("startup" . "$Id: startup.nw,v 1.17 1997/03/26 16:19:03 kehr Exp $") +;; line 1178 "markup.nw" + )) + +;; this should be the last of the module since it defines the +;; additional package `xindy'. +;; line 210 "startup.nw" +;; $Id: startup.nw,v 1.17 1997/03/26 16:19:03 kehr Exp $ + +(lisp:defpackage "XINDY") +(lisp:in-package "XINDY") + +(eval-when (compile load eval) + (lisp:use-package "BASE") + (lisp:use-package :xindy-version) + (lisp:use-package "MARKUP") + (lisp:use-package "CLOS") + (lisp:use-package "COMMON-LISP") + #+CLISP (lisp:use-package "EXT") + (lisp:import markup:*markup-user-interface-definitions*)) + +(eval-when (compile load eval) + (pushnew :HANDLER *features*)) +;; FIXME: error messages about package locks +;(eval-when (compile load eval) +; (pushnew :BREAK-DRIVER *features*)) + +;; line 44 "startup.nw" +(defun issue-startup-message () + (info "xindy kernel version: ~A~%" *xindy-kernel-version*) + (info "~A version ~A~% architecture: ~A~%" + (lisp-implementation-type) (lisp-implementation-version) + (machine-version)) + ) + +(defun startup (&key idxstyle rawindex output logfile + show-version markup-trace (trace-level 0)) + (when show-version + (issue-startup-message) + (exit-normally)) + (when markup-trace (setq *markup-verbose-mode* t)) + #+:HANDLER + (handler-case + (do-startup idxstyle rawindex output logfile trace-level) + (error + (condition) + (oops* (simple-condition-format-string condition) + (simple-condition-format-arguments condition)) + (error-exit))) + #-:HANDLER + (do-startup idxstyle rawindex output logfile trace-level)) +;; line 70 "startup.nw" +(defun do-startup (idxstyle raw-index output logfile trace-level) + (set-searchpath-by-environment) + (setq custom:*default-file-encoding* charset:iso-8859-1) + (when logfile + (info "~&Opening logfile ~S " logfile) + (handler-case + (setq *logging-stream* (open logfile + :direction :output + :if-does-not-exist :create + :if-exists :supersede)) + (error () + (oops "Opening logfile ~S failed!" logfile) + (error-exit))) + (info "(done)~%") + ;; Set necessary flags... + (setq *logging-on* t) + (case trace-level + (0) + (1 (setq *mappings-trace* t)) + (2 (setq *mappings-trace* t) (setq *locref-trace* t)) + (3 (setq *mappings-trace* t) (setq *locref-trace* t)) + (t (error "Invalid :trace-level ~S !" trace-level))) + #+:ORDRULES (when *mappings-trace* + (setq ordrules::*message-logging* 1)) + + (multiple-value-bind (sec min hour day mon year) + (get-decoded-time) + (gol t ";; This logfile was generated automatically by `xindy'~%") + (gol t ";; at ~2,'0D.~2,'0D.~4,'0D ~2,'0D:~2,'0D:~2,'0D~%" + day mon year hour min sec)) + (gol t ";; Indexstyle: ~S, Rawindex: ~S, Output: ~S~%~%" + idxstyle raw-index output) + ) + + (info "~&Reading indexstyle...~%") + (let ((*readtable* idxstyle:*indexstyle-readtable*)) + (idxstyle:do-require idxstyle)) + (info "~&Finished reading indexstyle.") + (info "~&Finalizing indexstyle... ") + (idxstyle:make-ready idxstyle:*indexstyle*) + (info "(done)~%~%") + + (info "~&Reading raw-index ~S..." raw-index) + (load raw-index :verbose nil) + (info "~&Finished reading raw-index.~%~%") + + (handler-case + (setq *markup-output-stream* + (open output + :direction :output + :if-does-not-exist :create + :if-exists :supersede)) + (error () + (oops "Opening file ~S failed!" output) + (error-exit))) + + (info "~&Processing index...") + (index:process-index index:*index*) + (info "~&Finished processing index.~%~%") + + (info "~&Writing markup...") + (markup:do-markup-index index:*index*) + (info "~%Markup written into file ~S.~%" output)) +;; line 139 "startup.nw" +(defun set-searchpath-by-environment () + (let ((sp (#+CLISP + system::getenv + #+ALLEGRO + sys:getenv + "XINDY_SEARCHPATH"))) + (when sp (idxstyle:set-searchpath-by-string sp)))) +;; line 170 "startup.nw" +#+:BREAK-DRIVER +(fmakunbound '*break-driver*) + +#+:BREAK-DRIVER +(defun *break-driver* (continuable + &optional (condition nil) (print-it nil) + &aux (may-continue + (or continuable + (and condition + (find-restart 'continue condition)) + ) ) + (interactive-p (interactive-stream-p *debug-io*)) + (commandsr '()) + ) + (declare (ignore may-continue interactive-p commandsr)) + ;; This when-clause is from Bruno Haible. + (when (and condition print-it) + (terpri *error-output*) + (write-string "*** - " *error-output*) + #+CLISP (system::print-condition condition *error-output*) + #-CLISP (print condition *error-output*) + ) + (format *ERROR-OUTPUT* "~&Bye.") + (error-exit)) + +#+:BREAK-DRIVER-OLD +(defun *break-driver* (continuable &rest rest) + (declare (ignore continuable rest)) + (format *ERROR-OUTPUT* "~&Bye.") + (error-exit)) + +#+:BREAK-DRIVER +(eval-when (compile load eval) + (export '*break-driver*)) + +;; line 230 "startup.nw" +(eval-when (compile load eval) + +;; line 135 "startup.nw" +(export '(startup *xindy-kernel-version*)) +;; line 232 "startup.nw" + ) diff --git a/Build/source/utils/xindy/xindy-2.4/src/ordrules.lsp b/Build/source/utils/xindy/xindy-2.4/src/ordrules.lsp new file mode 100644 index 00000000000..ea372eb94ea --- /dev/null +++ b/Build/source/utils/xindy/xindy-2.4/src/ordrules.lsp @@ -0,0 +1,419 @@ +;;; $Id$ +;;;---------------------------------------------------------------------- + +;;; +;;; ordrules --- order rules for xindy +;;; +;;; (history at end) + + +(provide "ordrules") + + +;;;; ============================================================ +;;;; +;;;; SPECIFICATION +;;;; + +;;; +;;; package ordrules XXX +;;; + +(defpackage "ORDRULES" + (:documentation "Order rules for xindy. +Provides functionality for merge-rules and sort-rules, as ordrule collections. +An ordrule collection is an ordered set of order rules. +An order rule is an object that manages replacement of a string or +regular expression by a string. +Ordrule collections are applied to strings, the result is created by +successive application of matching order rules.") + (:use common-lisp clos regexp) + (:shadow match) + (:export ;; object interface + "MAKE-ORDRULE-TABLE" "ADD-RULE" "APPLY-RULES" + ;; legacy (C plugin) interface + "INITIALIZE" "ADD-KEYWORD-MERGE-RULE" "ADD-KEYWORD-SORT-RULE" + "GEN-KEYWORD-MERGEKEY" "GEN-KEYWORD-SORTKEY" + "*MESSAGE-BUFFER-PTR*" "*MESSAGE-BUFFER*" "*MESSAGE-LOGGING*") + ) +(in-package "ORDRULES") + + + +;;;; ============================================================ +;;;; +;;;; ORDRULE OBJECTS +;;;; + +;;; class ORDRULE +;;; Slots: +;;; -- match: regexp, string, or char that might be matched +;;; -- repl: replacement for the matched substring +;;; -- again: boolean flag if repl should be eligible for further ordrules +;;; +;;; subclass ORDRULE-STRING -- no additional slots +;;; subclass ORDRULE-CHAR -- no additional slots +;;; subclass ORDRULE-REGEXP +;;; Additional Slots: +;;; -- only-at-start: boolean flag if match should only be tested at start +;;; of string + +(defclass ordrule () + ((match :initarg :match :reader match) + (repl :initarg :repl :reader repl) + (again :initarg :again :reader again)) + (:documentation + "An order rule that represents the replacement of a matching expression +with a replacement string.")) + +(defclass ordrule-string (ordrule) + () + (:documentation + "An ordrule where the matching expression is a string")) + +(defclass ordrule-char (ordrule) + () + (:documentation + "An ordrule where the matching expression is a char")) + +(defclass ordrule-regexp (ordrule) + ((pattern :initarg :pattern :reader pattern) + (only-at-start :initarg :only-at-start :reader only-at-start)) + (:documentation + "An ordrule where the matching expression is a regexp")) + +(defmethod print-object ((obj ordrule) stream) + "Print an ordrule." + (format stream "#<ordrule: '~A' => '~A' :again ~A>" + (match obj) (repl obj) (again obj))) + +(defmethod print-object ((obj ordrule-regexp) stream) + "Print an ordrule." + (format stream "#<ordrule-regexp: '~A' => '~A' :again ~A :only-at-start ~A>" + (pattern obj) (repl obj) (again obj) (only-at-start obj))) + +(defun make-ordrule-string (match repl &key again) + "Create an ordrule-string object. +MATCH is a string to compare." + (make-instance 'ordrule-string :match match :repl repl :again again)) + +(defun make-ordrule-char (match repl &key again) + "Create an ordrule-string object. +MATCH is a character to compare." + (make-instance 'ordrule-char :match match :repl (string repl) :again again)) + +(defun make-ordrule-regexp (match-pattern repl &key again (extended t)) + "Create an ordrule-regexp object. +MATCH-PATTERN is a POSIX regular expression. +The boolean keyword argument :extended tells if the regex is a basic +one or an extended one; default is to use extended ones." + (let* ((only-at-start (char= (char match-pattern 0) #\^)) + (match (if only-at-start (subseq match-pattern 1) match-pattern))) + (make-instance 'ordrule-regexp + :match (regexp-compile (concatenate 'string "^(" match ")") + :extended extended) + :repl repl :again again + :pattern match-pattern :only-at-start only-at-start))) + +;; A regexp-compile object does not survive dump and reload. +;; Therefore we have to initialize it at first usage. +(defvar *REGEXP-PATTERN* + nil + "If this pattern matches, the string is a regexp.") + +(defun make-ordrule (match repl &key again) + "Create an ordrule object. +MATCH may be a string, a char, or a POSIX regular expression. +If it's a regexp, it's an extended one." + (or *REGEXP-PATTERN* + (setq *REGEXP-PATTERN* (regexp-compile "[][|(){}.*+^$?]"))) + (cond ((characterp match) + (make-ordrule-char match repl :again again)) + ((= (length match) 1) + (make-ordrule-char (char match 0) repl :again again)) + ((regexp-exec *REGEXP-PATTERN* match) + (make-ordrule-regexp match repl :again again)) + (t (make-ordrule-string match repl :again again)))) + + +;;; +;;; (try-rule RULE SOURCE) => FINAL ; SOURCE-REST or <no values> +;;; + +(defgeneric try-rule (ordrule source &key at-start) + (:documentation "Apply an ordrule to a source string. +If the rule does not match, return nothing. If it matches, return two +values: the 1st is the final prefix with the replacement +string and the 2nd is the rest of SOURCE that's left after the matched +text. If the rule's again flag is true, FINAL will be the empty string +and the replacement will be at the start of SOURCE-REST. +An ordrule is not allowed to turn a source completely into an empty string. +If that would happen, a warning is output and nothing is returned. +That situation would exist, if AT-START is true and both FINAL and +SOURCE-REST would be empty. +AT-START tells if we are at the start to process the source string.")) + +(defmethod try-rule ((rule ordrule-char) source &key at-start) + (if (char= (char source 0) (match rule)) + (maybe-again-maybe-no rule source at-start + (repl rule) (subseq source 1)) + (values))) + +(defun maybe-again-maybe-no (rule source at-start repl source-rest) + (cond ((and at-start (string= repl "") (string= source-rest "")) + (warn "Would replace complete index key by empty string, ignoring ~S" rule) + (values source "")) + ((again rule) + (values "" (concatenate 'string repl source-rest))) + (t (values repl source-rest)))) + +(defmethod try-rule ((rule ordrule-string) source &key at-start) + (let* ((match-string (match rule)) + (match-length (length match-string))) + (cond ((> match-length (length source)) (values)) + ((string= source match-string :end1 match-length) + (maybe-again-maybe-no rule source at-start + (repl rule) (subseq source match-length))) + (t (values))))) + +(defmethod try-rule ((rule ordrule-regexp) source &key at-start) + (if (and (only-at-start rule) (not at-start)) + nil + (let ((match-regexp (multiple-value-list (regexp-exec (match rule) source)))) + (if match-regexp + (maybe-again-maybe-no rule source at-start + (maybe-repl-subexpr (repl rule) (rest match-regexp) source) + (subseq source (match-end (first match-regexp)))) + (values))))) + +;; A regexp-compile object does not survive dump and reload. +;; Therefore we have to initialize it at first usage. +(defvar *REPL-PATTERN* + nil + "Compiled regexp that matches a backpattern in a regexp replacement text.") + +;; We need to substitute all \x and & constructs in the replacement text by +;; the respective subexpression from source's matches. They are +;; located with a regexp in a loop and we collect in 'final-repl the +;; strings in front of each \x and the actual subexpression. +(defun maybe-repl-subexpr (repl source-matches source) + (or *REPL-PATTERN* + (setq *REPL-PATTERN* (regexp-compile "\\\\([1-9])|&" :extended t))) + (do* ((start 0 (match-end (first subexpr-match))) + (subexpr-match (multiple-value-list (regexp-exec *REPL-PATTERN* repl)) + (multiple-value-list (regexp-exec *REPL-PATTERN* repl + :start start))) + (final-repl "")) + ((null subexpr-match) + ;; Don't forget to return the rest of the string, too. Its + ;; index is now in 'start. + (concatenate 'string final-repl (subseq repl start))) + ;; OK, need a subexpr replacement. First, we determine which subexpression + ;; this shall be: If it's "&", the second match subexpression will be nil, + ;; as the parenthesis did not match anything. Otherwise the 2nd match + ;; subexpr will be the digit. Then we get that subexpression from the + ;; source string. Finally, we add the 'repl string part in front of \x and + ;; the respective subexpression to 'final-repl and are ready to look for + ;; our next \x construct. + (let* ((subexpr-match-struct (second subexpr-match)) + (subexpr (and subexpr-match-struct + (match-string repl subexpr-match-struct))) + (subexpr-repl (match-string source + (nth (if (null subexpr) + 0 + (read-from-string subexpr)) + source-matches)))) + (setq final-repl + (concatenate 'string final-repl + (subseq repl 0 (match-start (first subexpr-match))) + subexpr-repl))))) + + +;;; +;;; (rule-first-char RULE) => char or :regexp +;;; + +(defgeneric rule-first-char (rule) + (:documentation "Returns the first char of a rule match. +This returns either the first char of a rule match, or :regexp +if that first char is a regular expression. The is used to find the +slot for a rule in a rule table.")) + +(defmethod rule-first-char ((rule ordrule-char)) + (match rule)) + +(defmethod rule-first-char ((rule ordrule-string)) + (char (match rule) 0)) + +(defmethod rule-first-char ((rule ordrule-regexp)) + (let* ((pattern (pattern rule)) + (start-index (if (only-at-start rule) 1 0)) + (first-char (char pattern start-index))) + (cond ((char= first-char #\\) + (char pattern (1+ start-index))) + ((find first-char "[]|(){}.*+?") + :regexp) + (t first-char)))) + + + +;;;; ============================================================ +;;;; +;;;; ORDRULE TABLES +;;;; + +;; An ordrule table is a hash table of ordrule lists, indexed by the first +;; character of the rule. The key :regexp is the entry for rules that start +;; with a regexp pattern. + +(defclass ordrule-table () + ((table :initarg :table :reader table)) + (:documentation + "A collection of ordrules.")) + +(defmethod print-object ((obj ordrule-table) stream) + "Print an ordrule table." + (format stream "#<ordrule table with ~A entries>" (hash-table-count (table obj)))) + +(defun make-ordrule-table () + "Create an ordrule-table object." + (make-instance 'ordrule-table :table (make-hash-table :size 256))) + +(defun add-rule (rule-table rule) + "Add a rule to an ordrule table." + (let* ((first-char (rule-first-char rule)) + (first-char-rules (gethash first-char (table rule-table)))) + (if first-char-rules + (nconc first-char-rules (list rule)) + (setf (gethash first-char (table rule-table)) (list rule))))) + +;; XXX This is the place where we might want to sort rules according to their +;; length. But then we should also cache that sort result, because this +;; function is called for each character in the index! +;; +;; XXX Maybe we should try a cache anyhow, to save appends, too? Need to +;; measure that. +(defun get-rules (rule-table source-start) + (append (gethash source-start (table rule-table)) + (gethash :regexp (table rule-table)))) + +(defun apply-rules-once (rule-table source at-start) + "Apply rules from rule-table once to source. +Returns two values: (1) prefix that has been processed, (2) suffix that has +still to be processed." + (dolist (rule (get-rules rule-table (char source 0)) + (values)) + (multiple-value-bind (prefix suffix) + (try-rule rule source :at-start at-start) + (if (stringp prefix) + (return (values prefix suffix)))))) + +(defun apply-rules (rule-table source &optional (at-start t)) + "Apply rules from rule-table to source." + (multiple-value-bind (prefix suffix) + (apply-rules-once rule-table source at-start) + (log-rule (format nil "apply rules once: '~A' => '~A' '~A'~%" + source prefix suffix)) + (cond ((null prefix) + (if (= (length source) 1) + source + (concatenate 'string (subseq source 0 1) + (apply-rules rule-table (subseq source 1) nil)))) + ((string= suffix "") prefix) + (t (concatenate 'string prefix + (apply-rules rule-table suffix nil)))))) + + + +;;;; ============================================================ +;;;; +;;;; LEGACY (C PLUGIN) INTERFACE +;;;; + +;; The following code realizes the interface of xindy 2.3, even though we +;; could now use real Lisp objects. This is a transient phase only. + +(defvar *merge-rule-table* + (make-ordrule-table)) + +;; By default, we have runs 0..7. +(defvar *sort-rule-tables* + (let ((tables (make-array '(8) :element-type 'ordrule-table))) + (dotimes (i 8) + (setf (aref tables i) (make-ordrule-table))) + tables)) + +(defun initialize (num) + (setq *sort-rule-tables* (make-array (list num) :element-type 'ordrule-table)) + (dotimes (i num) + (setf (aref *sort-rule-tables* i) (make-ordrule-table)))) + +(defun add-keyword-rule (rule-table rule repl again ruletype) + (let* ((again (if (= again 1) t nil)) + (rule-obj (ecase ruletype + (0 (make-ordrule rule repl :again again)) + (1 (make-ordrule-string rule repl :again again)) + (2 (make-ordrule-regexp rule repl :again again :extended nil)) + (3 (make-ordrule-regexp rule repl :again again)) + (4 (make-ordrule-char rule repl :again again))))) + (add-rule rule-table rule-obj))) + +(defun add-keyword-merge-rule (rule repl again ruletype) + (let* ((rule-list (add-keyword-rule *merge-rule-table* rule + repl again ruletype)) + (message (format nil "Add merge rule: ~S~%" (first (last rule-list))))) + (log-rule message))) + +(defun add-keyword-sort-rule (run rule repl again ruletype) + (let* ((rule-list (add-keyword-rule (aref *sort-rule-tables* run) + rule repl again ruletype)) + (message (format nil "Add sort rule to run ~A: ~S~%" + run (first (last rule-list))))) + (log-rule message))) + +(defun gen-keyword-mergekey (key) + (let ((result (apply-rules *merge-rule-table* key))) + (log-rule (format nil "Final merge-rule result: '~A' -> '~A'~%" + key result)) + result)) + +(defun gen-keyword-sortkey (key run) + (let ((result (apply-rules (aref *sort-rule-tables* run) key))) + (log-rule (format nil "Final sort-rule result, run ~A: '~A' -> '~A'~%" + run key result)) + result)) + + +;;; +;;; Logging +;;; + +(defvar *message-logging* + nil + "Boolean: Shall rule replacement be logged?") + +(defvar *message-buffer* + "" + "String with the log message. +This is remaining cruft from the C plugin that could not use Lisp +output streams itself.") + +(defvar *message-buffer-ptr* + 0 + "Current position in *message-buffer*. +This is remaining cruft from the C plugin that could not use Lisp +output streams itself.") + +(defun log-rule (message) + (and *message-logging* + (if (= (incf *message-buffer-ptr*) 1) + (setq *message-buffer* message) + (setq *message-buffer* (concatenate 'string *message-buffer* + message))) + )) + + + +;;;====================================================================== +;; +;; $Log$ diff --git a/Build/source/utils/xindy/xindy-2.4/src/version.lsp b/Build/source/utils/xindy/xindy-2.4/src/version.lsp new file mode 100644 index 00000000000..e7b219bba94 --- /dev/null +++ b/Build/source/utils/xindy/xindy-2.4/src/version.lsp @@ -0,0 +1,13 @@ +;; $Id$ -*- Lisp -*- +;; ------------------------------------------------------------ +;; version identification of xindy kernel +;; src/version.lsp. + +(lisp:provide "version") + +(defpackage :xindy-version + (:export *xindy-kernel-version*)) + +(in-package :xindy-version) + +(defconstant *xindy-kernel-version* "3.0") |