diff options
Diffstat (limited to 'Build/source/utils/xindy-old/src')
-rw-r--r-- | Build/source/utils/xindy-old/src/Makefile.am | 25 | ||||
-rw-r--r-- | Build/source/utils/xindy-old/src/Makefile.in | 338 | ||||
-rw-r--r-- | Build/source/utils/xindy-old/src/base.lsp | 237 | ||||
-rw-r--r-- | Build/source/utils/xindy-old/src/dump-xindy.lsp | 32 | ||||
-rw-r--r-- | Build/source/utils/xindy-old/src/idxstyle.lsp | 2132 | ||||
-rw-r--r-- | Build/source/utils/xindy-old/src/index.lsp | 1332 | ||||
-rw-r--r-- | Build/source/utils/xindy-old/src/locref.lsp | 556 | ||||
-rw-r--r-- | Build/source/utils/xindy-old/src/markup.lsp | 1291 | ||||
-rw-r--r-- | Build/source/utils/xindy-old/src/version.lsp | 11 |
9 files changed, 0 insertions, 5954 deletions
diff --git a/Build/source/utils/xindy-old/src/Makefile.am b/Build/source/utils/xindy-old/src/Makefile.am deleted file mode 100644 index 528c9d7ef48..00000000000 --- a/Build/source/utils/xindy-old/src/Makefile.am +++ /dev/null @@ -1,25 +0,0 @@ -## Use `autoreconf' in top-level directory to recreate all -## autoconf/automake files. -## Or, call `automake Makefile' to create only Makefile.in. - -# Makefile for xindy - -## Copyright (C) 2004-2005 by Gour. -## Copyright (C) 2008 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. - -EXTRA_DIST = base.lsp dump-xindy.lsp idxstyle.lsp index.lsp locref.lsp markup.lsp version.lsp diff --git a/Build/source/utils/xindy-old/src/Makefile.in b/Build/source/utils/xindy-old/src/Makefile.in deleted file mode 100644 index 20483ee7415..00000000000 --- a/Build/source/utils/xindy-old/src/Makefile.in +++ /dev/null @@ -1,338 +0,0 @@ -# Makefile.in generated by automake 1.11.1 from Makefile.am. -# @configure_input@ - -# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, -# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, -# Inc. -# This Makefile.in is free software; the Free Software Foundation -# gives unlimited permission to copy and/or distribute it, -# with or without modifications, as long as this notice is preserved. - -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY, to the extent permitted by law; without -# even the implied warranty of MERCHANTABILITY or FITNESS FOR A -# PARTICULAR PURPOSE. - -@SET_MAKE@ - -# Makefile for xindy -VPATH = @srcdir@ -pkgdatadir = $(datadir)/@PACKAGE@ -pkgincludedir = $(includedir)/@PACKAGE@ -pkglibdir = $(libdir)/@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 = src -DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.in -ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 -am__aclocal_m4_deps = $(top_srcdir)/m4/tl_msg_error.m4 \ - $(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 = -DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) -ACLOCAL = @ACLOCAL@ -AMTAR = @AMTAR@ -AUTOCONF = @AUTOCONF@ -AUTOHEADER = @AUTOHEADER@ -AUTOMAKE = @AUTOMAKE@ -AWK = @AWK@ -CC = @CC@ -CCDEPMODE = @CCDEPMODE@ -CFLAGS = @CFLAGS@ -CLISP = @CLISP@ -CLISP_LIB = @CLISP_LIB@ -CONVERT_FROM_UTF8 = @CONVERT_FROM_UTF8@ -CPP = @CPP@ -CPPFLAGS = @CPPFLAGS@ -CYGPATH_W = @CYGPATH_W@ -DEFS = @DEFS@ -DEPDIR = @DEPDIR@ -ECHO_C = @ECHO_C@ -ECHO_N = @ECHO_N@ -ECHO_T = @ECHO_T@ -EGREP = @EGREP@ -EXEEXT = @EXEEXT@ -GREP = @GREP@ -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@ -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@ -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@ -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@ -EXTRA_DIST = base.lsp dump-xindy.lsp idxstyle.lsp index.lsp locref.lsp markup.lsp version.lsp -all: all-am - -.SUFFIXES: -$(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 src/Makefile'; \ - $(am__cd) $(top_srcdir) && \ - $(AUTOMAKE) --foreign 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): -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 -installdirs: -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: - -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-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: - -.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-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 - - -# 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-old/src/base.lsp b/Build/source/utils/xindy-old/src/base.lsp deleted file mode 100644 index 4158d212f7b..00000000000 --- a/Build/source/utils/xindy-old/src/base.lsp +++ /dev/null @@ -1,237 +0,0 @@ -;; line 30 "base.nw" -(lisp:defpackage "BASE") -(lisp:in-package "BASE") -(lisp:provide "base") - -#+:CMU17 (defpackage "CLOS") - -(eval-when (compile load eval) - (lisp:use-package "CLOS") - (lisp:use-package "COMMON-LISP") - #+CLISP (lisp:use-package "EXT") - ) - -(eval-when (eval load compile) - #+CLISP (when (find-package "XP") - (pushnew :XP *features*)) - #+(or ALLEGRO :CMU17) (pushnew :XP *features*) - ) - -(setq *print-pretty* t) -(setq *print-escape* t) - -(defparameter *mappings-trace* nil) -(defparameter *locref-trace* nil) -(eval-when (compile load eval) - (export '(*mappings-trace* *locref-trace*))) - -;; line 104 "base.nw" -#-CLISP -(defmacro simple-condition-format-string (&rest args) - `(simple-condition-format-control ,@args)) -#-CLISP -(eval-when (compile load eval) - (export '(simple-condition-format-string))) -;; line 133 "base.nw" -(defmacro info (&rest msg) - `(APPLY #'FORMAT *STANDARD-OUTPUT* (LIST ,@msg))) -;; line 138 "base.nw" -(defparameter *nraw-error-message* "~&WARNING: ") - -(defmacro nraw (&rest msg) - `(PROGN - (FORMAT *ERROR-OUTPUT* BASE::*NRAW-ERROR-MESSAGE*) - (APPLY #'FORMAT *ERROR-OUTPUT* (LIST ,@msg)))) -;; line 147 "base.nw" -(defparameter *oops-error-message* "~&ERROR: ") - -(defmacro oops (&rest msg) - `(LET ((MSG (LIST ,@msg))) - (FORMAT *ERROR-OUTPUT* BASE::*OOPS-ERROR-MESSAGE*) - (APPLY #'FORMAT *ERROR-OUTPUT* MSG) - (WHEN *LOGGING-ON* - (FORMAT *LOGGING-STREAM* BASE::*OOPS-ERROR-MESSAGE*) - (APPLY #'FORMAT *LOGGING-STREAM* MSG)))) -;; line 162 "base.nw" -(defmacro oops* (fmt args) - `(LET ((FMT ,fmt) - (ARGS ,args)) - (FORMAT *ERROR-OUTPUT* BASE::*OOPS-ERROR-MESSAGE*) - (APPLY #'FORMAT *ERROR-OUTPUT* FMT ARGS) - (WHEN *LOGGING-ON* - (FORMAT *LOGGING-STREAM* BASE::*OOPS-ERROR-MESSAGE*) - (APPLY #'FORMAT *LOGGING-STREAM* FMT ARGS)))) -;; line 183 "base.nw" -(defparameter *logging-stream* nil) -(defparameter *logging-on* nil) - -(defmacro gol (flag &rest msg) - `(WHEN (AND ,flag *LOGGING-ON*) - (APPLY #'FORMAT *LOGGING-STREAM* (list ,@msg)))) -;; line 74 "base.nw" -(defmacro ifnot (expr then-body else-body) - `(IF (NOT ,expr) ,then-body ,else-body)) -;; line 82 "base.nw" -(defun error-exit () - #+CLISP (exit 1) - #+ALLEGRO (excl:exit 1) - #+CMU17 (unix:unix-exit 1) - ) - -(defun exit-normally () - #+CLISP (exit 0) - #+ALLEGRO (excl:exit 0) - #+CMU17 (unix:unix-exit 0) - ) -;; line 201 "base.nw" -(defmacro assert! (cond &optional msg) - `(UNLESS ,cond - (FORMAT *ERROR-OUTPUT* "Internal error! Assertion ~A failed!" ',cond) - ,(if msg - `(ERROR "~S" ,msg) - `(ERROR "Entering debugger!")))) - -(pushnew :ASSERT! *features*) -;; line 218 "base.nw" -(defmacro define-slot-accessors (accessors) - `(eval-when (compile load eval) - ,@(apply #'nconc - (mapcar - #'(lambda (acc) - (let ((getnam (intern (concatenate 'string "GET-" - (symbol-name acc)))) - (setnam (intern (concatenate 'string "SET-" - (symbol-name acc)))) - ) - `((defmacro ,getnam (obj) - (list 'slot-value obj '',acc)) - (defmacro ,setnam (val obj) - (list 'setf (list 'slot-value obj '',acc) val)) - (export '(,getnam ,setnam ,acc))))) - accessors)))) - -(define-slot-accessors ( - attribute - base-alphabet - basetype - catattr - catattr-grp-ordnum - entries - entry-list - entry-table - first - group-definition - hierdepth - idxclass - inner - join-length - last - last-in-group - layers - length - letters - locclass - locref-cache - locref-string - locrefs - members - merge-key - sort-key - print-key - main-key - name - order - ordnum - ordnums - origin - processing-ordnum - props - rangeattr - separator - sort-ordnum - state - subentries - subrefs - symbols - target - type - )) -;; line 297 "base.nw" -(defun split-list (split-function list &key sortfunc headfunc) - #+:ASSERT! (assert (not (and sortfunc headfunc)) - () - "split-list") - (let ((list-len (length list))) - (if (= 1 list-len) - (list list) - (let ((split-table (make-hash-table :test #'equal - :size (round (* 1.2 list-len)))) - (key-list '())) - (mapc #'(lambda (elt) - (let ((key (funcall split-function elt))) - (setf (gethash key split-table) - (cons elt (gethash key split-table))))) - list) - (maphash #'(lambda (key element) - (declare (ignore element)) - (push key key-list)) - split-table) - (maplist #'(lambda (rest-list) - (let ((entries (gethash (car rest-list) split-table))) - (if headfunc - (let ((head (find-if headfunc entries))) - (rplaca rest-list - (if head - (cons head (delete head entries)) - entries))) - (rplaca rest-list entries)))) - (if sortfunc (sort key-list sortfunc) key-list)) - key-list)))) - -#| -This version seems to be a little bit slower than the above one, -despite the fact that we use a temporary array with a fill-pointer. - -(defun split-list (split-function sort-function list) - (let ((list-len (length list))) - (if (= 1 list-len) - (list list) - (let ((split-table (make-hash-table :test #'equal - :size (round (* 1.5 list-len))))) - (mapc #'(lambda (elt) - (let ((key (funcall split-function elt))) - (setf (gethash key split-table) - (cons elt (gethash key split-table))))) - list) - (let ((sort-array (make-array (hash-table-count split-table) - :fill-pointer 0))) - (maphash #'(lambda (key element) - (declare (ignore element)) - (vector-push key sort-array)) - split-table) - (map 'list - #'(lambda (key) - (gethash key split-table)) - (sort sort-array sort-function))))))) -|# - -;; line 60 "base.nw" -(defvar *RCS-Identifier* '( -;; line 68 "base.nw" -("base" . "$Id: base.nw,v 1.20 1997/03/26 16:17:58 kehr Exp $") -;; line 60 "base.nw" - )) - -(eval-when (compile load eval) - -;; line 96 "base.nw" -(export '(ifnot error-exit exit-normally)) -;; line 192 "base.nw" -(export '(oops oops* nraw info gol - *logging-stream* *logging-on*)) -;; line 212 "base.nw" -(export 'assert!) -;; line 357 "base.nw" -(export '(split-list)) -;; line 64 "base.nw" - ) diff --git a/Build/source/utils/xindy-old/src/dump-xindy.lsp b/Build/source/utils/xindy-old/src/dump-xindy.lsp deleted file mode 100644 index 4e48ab50efa..00000000000 --- a/Build/source/utils/xindy-old/src/dump-xindy.lsp +++ /dev/null @@ -1,32 +0,0 @@ -;; $Id: dump-xindy.xdy,v 1.2 1996/08/02 17:41:07 kehr Exp $ -;; ---------------------------------------------------------------------- -;; -;; This file is necessary to dump xindy. -;; - -#+CLISP (setq custom:*suppress-check-redefinition* t) - -(load 'base) -(load 'locref) -(load '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-old/src/idxstyle.lsp b/Build/source/utils/xindy-old/src/idxstyle.lsp deleted file mode 100644 index 9e406d884d5..00000000000 --- a/Build/source/utils/xindy-old/src/idxstyle.lsp +++ /dev/null @@ -1,2132 +0,0 @@ -;; line 289 "idxstyle.nw" -;; $Id: idxstyle.nw,v 1.19 1997/03/26 16:18:23 kehr Exp $ -;; - -(lisp:defpackage "IDXSTYLE") -(lisp:in-package "IDXSTYLE") -(lisp:provide "idxstyle") - -#+CLISP (lisp:require "base") -#+CLISP (lisp:require "locref") - -(eval-when (compile load eval) - (lisp:use-package "CLOS") - (lisp:use-package "COMMON-LISP") - #+CLISP (lisp:use-package "EXT") - #+(and :XP CLISP) (lisp:use-package "XP") - #-CLISP (lisp:require "base") - #-CLISP (lisp:require "locref") - (lisp:use-package "BASE") - (lisp:use-package "LOCREF") - -;; line 472 "intface.nw" -(eval-when (eval load compile) - (when (find-package "ORDRULES") - (pushnew :ORDRULES *features*))) -;; line 306 "idxstyle.nw" - ;; see submodule intface - ) - -;; line 78 "idxstyle.nw" -(defparameter *indexstyle* nil) -(defparameter *indexstyle-readtable* (copy-readtable)) -(defparameter *included-files* '()) -(defvar *load-paths* "") -(defparameter *default-load-paths* *load-paths*) - -(defparameter *default-minimum-range-length* 2) -(defparameter *default-locref-hierdepth* 0) - -;; line 1151 "intface.nw" -;; $Id: intface.nw,v 1.30 1997/10/20 11:25:09 kehr Exp $ - -;; line 1016 "intface.nw" -;;; $Id: intface.nw,v 1.30 1997/10/20 11:25:09 kehr Exp $ -;;;---------------------------------------------------------------------- - -;;; -;;; util-lib LISP Utitlity Library -;;; -;;; (history at end) - - -;(provide 'util-lib) -;(in-package 'util-lib) - -(defvar whole) -(eval-when (compile load eval) - (export '(destructuring-switch-bind &switch whole))) - -(defmacro destructuring-switch-bind (lambdalist expr . body) - "Similar to 'destructuring-bind' but also allows switch options at the -end of LAMBDALIST with the following syntax: - - &switch { var | (var key [defval]) | (var ({ key }*) [defval]) }* - -In all cases VAR will be accessible in BODY as a variable. - -If only VAR is specified, it is bound to the keyword with the same -name, if that keyword occured in EXPR. Otherwise it is bound to NIL. - -If both a VAR and KEY were specified, VAR will be bound to KEY, if KEY -occured in EXPR and to NIL otherwise. - -If VAR and a list of KEYs were specified, VAR will be bound to the -first KEY, which occured in EXPR. If none of the KEYS occured within -EXPR, VAR will be bound to NIL. - -If DEFVAL was specified, variable will be bound to DEFVAL instead of -NIL in cases where no switch keyword was found in EXPR. -" - - (let* ((switchlist (member '&switch lambdalist)) - - ;; 'remove' switches from lambdalist - (lambdalist (ldiff lambdalist switchlist)) - - ;; drop &switch keyword - (switches (when switchlist (cdr switchlist))) - - ;; construct bindings for each switch and collect valid - ;; keywords in 'switchkeys' - (switchkeys '()) - (bindings - (mapcar - #'(lambda (spec) - (cond - - ;; spec simply consists of VAR - ((symbolp spec) - (let ((key (intern (symbol-name spec) 'keyword))) - (push key switchkeys) - `(,spec (FIND ,key <DESTRUCTURING-SWITCH-FORM>)) - )) - - ;; spec is (VAR form) - ((and (listp spec) (>= (list-length spec) 2)) - (let ((var (first spec)) - (keyspec (second spec)) - (defval (when (cddr spec) (third spec)))) - (cond - ;; spec is (VAR (KEY1 KEY2 ...)) - ((listp keyspec) - `(,var - (COND - ,@(mapcar - #'(lambda (key) - (push key switchkeys) - `((FIND ,key <DESTRUCTURING-SWITCH-FORM>) - ,key)) - keyspec) - (T ,defval)))) - - ;; spec is (VAR KEY) - (t - (push keyspec switchkeys) - ` (,var (OR - (FIND ,keyspec <DESTRUCTURING-SWITCH-FORM>) - ,defval))) - ))) - - ;; illegal spec - (t (error "~A is not a valid switch specifier." spec)) - )) - switches)) - ) - - ;; construct the expansion form - ` (LET ((<DESTRUCTURING-SWITCH-FORM> ,expr)) - (LET ,bindings - (HANDLER-CASE - (DESTRUCTURING-BIND ,lambdalist - (SET-DIFFERENCE-KEEP-ORIGINAL-ORDER - <DESTRUCTURING-SWITCH-FORM> - ',switchkeys) - ,@body) - (ERROR (COND) - (DECLARE (IGNORE COND)) - (ERROR "~&Syntax Error in ~S." WHOLE) - ) - ) - ) - ) - )) - -(defun set-difference-keep-original-order (set1 set2) - (mapcan #'(lambda (elt) - (unless (member elt set2) - (list elt))) - set1)) - -#| -(destructuring-switch-bind (name &rest args &key foo bar - &switch - on ; simple form - (started :start) - (speed (:fast :slow)) - (off :turn-off :turn-on) ; with switch key - (choose (:one :two :three) :three)) - '(width :foo 5 :bar 7 :on :turn-off :one) - (list name foo bar args on started speed off choose)) -|# -;; line 111 "intface.nw" -(eval-when (compile load eval) - (defun stringify (name) - (declare (inline)) - (etypecase name - (symbol (symbol-name name)) - (string name) - (number (write-to-string name))))) - -(defun list-of-strings-p (x) - (cond ((not (listp x)) nil) - ((every #'(lambda (elt) - (or (stringp elt) (symbolp elt) (numberp elt))) - x)))) -;; line 136 "intface.nw" -(defun make-well-formed-list (attr-list) - (mapcar #'(lambda (x) - (cond ((null x) - (error "empty lists are not allowed !")) - ((or (symbolp x) (stringp x) (numberp x)) - (list (stringify x))) - ((listp x) - (map-to-strings x)))) - attr-list)) - -(defun map-to-strings (slist) - (mapcar #'(lambda (x) - (cond ((null x) - (error "empty lists are not allowed !")) - ((or (symbolp x) (stringp x) (numberp x)) - (stringify x)) - ((listp x) - (error "nesting level too deep !")) - (t (error "~S is not a string !" x)))) - slist)) -;; line 185 "intface.nw" -(defun c-string-reader (stream char) - (declare (ignore char)) - (let ((ch nil) - (str (make-array 32 - :element-type - #+CLISP 'string-char - #-CLISP 'base-char - :adjustable t - :fill-pointer 0))) - (loop - (setq ch (read-char stream t #\Newline t)) - (case ch - (#\" (let ((nextch (read-char-no-hang stream t #\Newline t))) - (when nextch - (unread-char nextch stream) - (case nextch - (#\Newline) - (#\t) - (#\Space) - (#\)) - (t (nraw "~&Possible read-error due to ill-formed string \"~A\" ~S" - str *)))) - (return str))) - (#\~ (setq ch (read-char stream t #\Newline t)) - (case ch - (#\n (vector-push-extend #\Newline str)) - (#\t (vector-push-extend #\Tab str)) - (#\b (vector-push-extend (character 1) str)) - (#\e (vector-push-extend (character 255) str)) - (t (vector-push-extend ch str)))) - (t (vector-push-extend ch str)))))) - -(set-macro-character #\" #'c-string-reader nil *indexstyle-readtable*) - -#| -(let ((x #\Null)) - (loop for i from 1 to 255 - do (progn (print (character i)) - (when (char>= x (character i)) - (print "Whee!")) - (setq x (character i))))) -|# -;; line 254 "intface.nw" -(defmacro define-alphabet (&whole whole &optional name string-list) - (cond -;; line 239 "intface.nw" -((null name) - (error "missing argument <name> in `~S' !" whole)) -((not (or (symbolp name) (stringp name))) - (error "~S is not a symbol or a string in `~S' !" name whole)) -;; line 256 "intface.nw" - ((not (listp string-list)) - (error "missing argument <string-list> !")) - ((not (list-of-strings-p string-list)) - (error "~S is not a list of strings" string-list)) - (t `(LET ((NAME (STRINGIFY ',name))) - (WHEN (LOOKUP-BASETYPE *indexstyle* NAME) - (NRAW "redefining alphabet `~S'" NAME)) - (ADD *indexstyle* (MAKE-ALPHABET NAME ',string-list)))))) - -(defmacro define-alphabet* (&whole whole &optional name string-list) - (cond -;; line 239 "intface.nw" -((null name) - (error "missing argument <name> in `~S' !" whole)) -((not (or (symbolp name) (stringp name))) - (error "~S is not a symbol or a string in `~S' !" name whole)) -;; line 267 "intface.nw" - ((not (listp string-list)) - (error "missing argument <string-list> !")) - (t (let ((scar (car string-list))) - (if (and (symbolp scar) (fboundp scar)) - `(LET ((NAME (STRINGIFY ',name)) - (STRING-LIST ,string-list)) #| evaluates string-list |# - (UNLESS (LIST-OF-STRINGS-P STRING-LIST) - (ERROR "~S is not a list of strings" STRING-LIST)) - (WHEN (LOOKUP-BASETYPE *indexstyle* NAME) - (NRAW "redefining alphabet `~S'" NAME)) - (ADD *indexstyle* (MAKE-ALPHABET NAME STRING-LIST)))))))) -;; line 284 "intface.nw" -(defmacro define-enumeration (&whole - whole - &optional - name prefix-match-func base-alphabet) - (cond -;; line 239 "intface.nw" -((null name) - (error "missing argument <name> in `~S' !" whole)) -((not (or (symbolp name) (stringp name))) - (error "~S is not a symbol or a string in `~S' !" name whole)) -;; line 289 "intface.nw" - ((null prefix-match-func) - (error "missing argument <prefix-match-function> !")) - (t (let* ((name (stringify name)) - (symbol (make-symbol - (concatenate 'string "ENUMERATION-" name)))) - `(LET () #| PROGN instead of LET () yields a runtime error !? |# - (IF (LOOKUP-BASETYPE *indexstyle* ,name) - (NRAW "redefining alphabet `~S'" ,name) - (PROGN - (DEFCLASS ,symbol (ENUMERATION) ()) - (ADD *indexstyle* - (MAKE-ENUMERATION ',symbol ,name ,base-alphabet)))) - (DEFMETHOD PREFIX-MATCH ((STR STRING) (ENUM ,symbol)) - (FUNCALL ,prefix-match-func STR))))))) -;; line 312 "intface.nw" -(defmacro define-location-class (&whole whole &rest args) - (destructuring-switch-bind (name - layer-list - &key - (min-range-length *default-minimum-range-length*) - (hierdepth 0) ;no hierarchies are to be formed - &switch - (var :var)) - args - (cond - ((null name) - (error "missing argument <name> in~%~S" whole)) - ((null layer-list) - (error "missing argument <layer-list> in~%~S" whole)) - ;;((not (list-of-strings-p layer-list)) - ;; (error "~S is not a list of strings in~%~S" layer-list whole)) - ((not (numberp hierdepth)) - (error "~S is not a number! in~%~S" hierdepth whole)) - ((not (or (numberp min-range-length) - (eql 'none min-range-length))) - (error "~S must be a number or the keyword `none' in~%~S" - min-range-length whole)) - (t (when (eql 'none min-range-length) - (setq min-range-length 0)) - `(LET ((NAME (STRINGIFY ',name)) - (LAYERS (BUILD-LOCCLASS-LAYERS ',layer-list ',whole))) - ;;(GOL T "~&define-location-class: ~S" LAYERS) - (COND ((LOOKUP-CROSSREF-CLASS *indexstyle* NAME) - (OOPS "replacing cross-reference-class `~S' is not allowed !" - NAME)) - (t (WHEN (LOOKUP-LOCATION-CLASS *indexstyle* NAME) - (NRAW "redefining location-reference-class `~S' !" NAME)) - (ADD *indexstyle* - ,(if var - `(CHECKED-MAKE-VAR-LOCATION-CLASS NAME LAYERS - ,hierdepth) - `(CHECKED-MAKE-STANDARD-LOCATION-CLASS NAME LAYERS - ,min-range-length ,hierdepth)))) - )))))) -;; line 354 "intface.nw" -(defun build-locclass-layers (layers whole) - (let ((res-list '())) - (loop - ;;(gol t "~&build-locclass-layers: ~S" layers) - (when (endp layers) (return (nreverse res-list))) - (cond ((eql :sep (car layers)) - (setq layers (cdr layers)) - (if (endp layers) - (error "Reached end of list in~%~S" whole) - (push (make-loccls-separator (stringify (car layers))) - res-list))) - (t (let* ((layer (stringify (car layers))) - (basetype (lookup-basetype *indexstyle* layer))) - (if basetype - (push (make-loccls-layer basetype) res-list) - (error "Unknown basetype ~S in~%~S" layer whole))))) - (setq layers (cdr layers))))) -;; line 377 "intface.nw" -(defmacro define-crossref-class (&whole whole &rest args) - (destructuring-switch-bind (name - &switch (verified :unverified)) - args - (cond -;; line 239 "intface.nw" -((null name) - (error "missing argument <name> in `~S' !" whole)) -((not (or (symbolp name) (stringp name))) - (error "~S is not a symbol or a string in `~S' !" name whole)) -;; line 382 "intface.nw" - (t `(LET ((NAME (STRINGIFY ',name))) - (cond ((LOOKUP-LOCATION-CLASS *indexstyle* NAME) - (OOPS "replacing location-reference-class `~S' is not allowed !" - NAME)) - (t (WHEN (LOOKUP-CROSSREF-CLASS *indexstyle* NAME) - (NRAW "redefining crossref-location-class `~S'" NAME)) - (ADD *indexstyle* - ,(if verified - `(MAKE-UNVERIFIED-CROSSREF-LOCATION-CLASS NAME) - `(MAKE-VERIFIED-CROSSREF-LOCATION-CLASS NAME)))))))))) -;; line 398 "intface.nw" -(defmacro define-location-class-order (olist) - (cond ((not (listp olist)) - (error "missing argument <list> !")) - ((not (list-of-strings-p olist)) - (error "~S is not a list of strings" olist)) - (t `(LET ((CTR 1)) - (MAPC #'(LAMBDA (NAME) - (LET* ((NEW-NAME (STRINGIFY NAME)) - (LOCCLS - (CDR (LOOKUP-LOCATION-CLASS *indexstyle* - NEW-NAME)))) - (INCF CTR) - (COND (LOCCLS (SET-ORDNUM CTR LOCCLS)) - (t (OOPS "unknown location-class `~S'" - NEW-NAME))))) - ',olist))))) -;; line 423 "intface.nw" -(defmacro define-attributes (&whole whole &optional attr-list) - (cond ((null attr-list) - (error "missing argument <attribute-list> in~&~S" whole)) - (t (let* ((wf-attr-list (make-well-formed-list attr-list)) - (plain-list (apply #'concatenate 'list wf-attr-list)) - ) - `(PROGN - (MAPCAR - #'(LAMBDA (CATATTR) - (IF (LOOKUP-CATATTR *indexstyle* CATATTR) - (NRAW "ignoring redefinition of attribute ~S in~&~S" - CATATTR ',whole) - (ADD *indexstyle* - (MAKE-CATEGORY-ATTRIBUTE CATATTR)))) - ',plain-list) - (INITIALIZE-CATEGORY-ATTRIBUTES ',wf-attr-list *indexstyle*)) - )))) -;; line 488 "intface.nw" -#+:ORDRULES -(defmacro merge-rule (&whole whole &rest args) - (destructuring-switch-bind (pattern - replacement - &switch - (again :again) - (string :string) - (extended-regexp :eregexp) - (basic-regexp :bregexp)) - args - (cond ((null pattern) - (error "missing argument <pattern> !")) - ((or (and string extended-regexp) (and string basic-regexp) - (and extended-regexp basic-regexp)) - (error "~&Only one of (:string :bregexp :eregexp) allowed in:~&~S !" - whole)) - ((null replacement) - (error "~&Missing argument <replacement> in:~&~S!" whole)) - (t `(PROGN - (UNLESS - (ZEROP - (ORDRULES:ADD-KEYWORD-MERGE-RULE ,pattern ,replacement - ,(if again 1 0) - ,(cond (string 1) - (basic-regexp 2) - (extended-regexp 3) - (t 0)))) - (OOPS "~&Wrong regular expression ~S in:~%~S." ',pattern ',whole)) - (FLUSH-ORDRULES-MESSAGE-BUFFER)))))) - -#-:ORDRULES -(defmacro merge-rule (&rest args) - (declare (ignore args)) - (oops "merge-rule not supported! ignoring definition")) -;; line 525 "intface.nw" -#+:ORDRULES -(defparameter *sort-rule-orientations* - '(forward forward forward forward - forward forward forward forward)) - -#+:ORDRULES -(defmacro define-sort-rule-orientations (&whole whole &rest args) - (destructuring-switch-bind (&optional - (orientations *sort-rule-orientations*)) - args - (unless (every #'(lambda (run) - (member run '(forward backward))) - orientations) - (error "~&Elements of ~S must be one of {forward,backward}!" - orientations)) - `(PROGN - (SETQ *SORT-RULE-ORIENTATIONS* ',orientations) - (ORDRULES:INITIALIZE (LENGTH *SORT-RULE-ORIENTATIONS*)) - (FLUSH-ORDRULES-MESSAGE-BUFFER)))) - -#+:ORDRULES -(defmacro define-rule-set (&whole whole &rest args) - (destructuring-bind (&optional - name - &key - inherit-from - rules) - args - (cond -;; line 239 "intface.nw" -((null name) - (error "missing argument <name> in `~S' !" whole)) -((not (or (symbolp name) (stringp name))) - (error "~S is not a symbol or a string in `~S' !" name whole)) -;; line 554 "intface.nw" - ((not (listp rules)) - (error "missing argument <rules-list> !")) - (t `(LET ((RS (MAKE-RULE-SET ',name ',inherit-from ',rules))) - (MAPC #'(LAMBDA (INH-NAME) - (INHERIT-RULE-SET RS (LOOKUP-RULE-SET *INDEXSTYLE* - INH-NAME))) - ',inherit-from) - (ADD-RULE-SET *INDEXSTYLE* RS)))))) - -#-:ORDRULES -(defmacro define-rule-set (&rest args) - (declare (ignore args)) - (oops "define-rule-sets not supported! ignoring definition")) - -#+:ORDRULES -(defmacro use-rule-set (&whole whole &rest args) - ;; FIXME: if we use destructuring-switch-bind-here an error occurs - (destructuring-bind (&key - run - rule-set) - args - (cond ((not (integerp run)) - (error "incorrect argument <run> !")) - ((not rule-set) - (error "missing argument <rule-set> !")) - ((not (or (listp rule-set) - (stringp rule-set))) - (error "wrong argument to <rule-set> !")) - (t `(INSTANTIATE-RULE-SET ,run ,rule-set))))) - -#-:ORDRULES -(defmacro use-rule-set (&rest args) - (declare (ignore args)) - (oops "use-rule-sets not supported! ignoring definition")) - -#+:ORDRULES -(defmacro sort-rule (&whole whole &rest args) - (destructuring-switch-bind (pattern - replacement - &key - (run 0) - &switch - (again :again) - (string :string) - (extended-regexp :eregexp) - (basic-regexp :bregexp)) - args - (cond ((null pattern) - (error "missing argument <pattern> !")) - ((or (< run 0) (>= run (length *sort-rule-orientations*))) - (error "~&Argument of :run must be in the interval [0..~A]!" - (length *sort-rule-orientations*))) - ((or (and string extended-regexp) (and string basic-regexp) - (and extended-regexp basic-regexp)) - (error "~&Only one of (:string :bregexp :eregexp) allowed in:~&~S !" - whole)) - ((null replacement) - (error "missing argument <replacement> !")) - (t `(PROGN - (UNLESS - (ZEROP - (ORDRULES:ADD-KEYWORD-SORT-RULE ,run ,pattern ,replacement - ,(if again 1 0) - ,(cond (string 1) - (basic-regexp 2) - (extended-regexp 3) - (t 0)))) - (OOPS "~&Wrong regular expression ~S in:~%~S." ',pattern ',whole)) - (FLUSH-ORDRULES-MESSAGE-BUFFER)))))) - -#-:ORDRULES -(defmacro define-sort-rule-orientations (&rest args) - (declare (ignore args)) - (oops "define-sort-rule-orientations not supported! ignoring definition")) - -#-:ORDRULES -(defmacro sort-rule (&rest args) - (declare (ignore args)) - (oops "sort-rule not supported! ignoring definition")) - -(defun flush-ordrules-message-buffer () - #+:ORDRULES - (when (and *mappings-trace* ordrules::*message-logging*) - (gol t "~A" ordrules::*message-buffer*) - (setq ordrules::*message-buffer-ptr* 0))) -;; line 696 "intface.nw" -(defmacro define-letter-group - (&whole whole name &key prefixes before after) - (cond -;; line 239 "intface.nw" -((null name) - (error "missing argument <name> in `~S' !" whole)) -((not (or (symbolp name) (stringp name))) - (error "~S is not a symbol or a string in `~S' !" name whole)) -;; line 699 "intface.nw" - ((and before - (not (lookup-letter-group-definition *indexstyle* before))) - (error "~S does not name a letter group in~%~S" before whole)) - ((and after - (not (lookup-letter-group-definition *indexstyle* after))) - (error "~S does not name a letter group in~%~S" after whole)) - ((not (list-of-strings-p prefixes)) - (error "argument <prefixes> is not a list of strings in~%~S" - whole)) - (t `(LET () - (ADD-LETTER-GROUPS *INDEXSTYLE* - ,name ',(or prefixes (list name)) - :BEFORE ,before :AFTER ,after))))) -;; line 718 "intface.nw" -(defmacro define-letter-groups (&whole whole &optional letter-groups) - (cond ((not (list-of-strings-p letter-groups)) - (error "~S is not a list of strings in~%~S" letter-groups whole)) - (t `(LET () - (ADD-LETTER-GROUPS *INDEXSTYLE* - ,(car letter-groups) ',(list (car letter-groups))) - ,@(let ((last (car letter-groups))) - (mapcar #'(lambda (letter-group) - (prog1 - `(ADD-LETTER-GROUPS *INDEXSTYLE* - ,letter-group ',(list letter-group) - :AFTER ,last) - (setq last letter-group))) - (cdr letter-groups))))))) -;; line 650 "intface.nw" -(defmacro merge-to (&whole whole &rest args) - (destructuring-switch-bind (from to &switch drop) - args - (let ((from-attr (lookup-catattr *indexstyle* from)) - (to-attr (lookup-catattr *indexstyle* to))) - (cond ((not from-attr) - (nraw "`~S' is not a known attribute in:~&~A" from whole)) - ((not to-attr) - (nraw "`~S' is not a known attribute in:~&~A" to whole)) - (t (if drop - `(ADD-DROP-IF-MERGED-RULE *INDEXSTYLE* - ',from-attr ',to-attr) - `(ADD-MERGE-RULE *INDEXSTYLE* - ',from-attr ',to-attr))))))) -;; line 740 "intface.nw" -;;; we remove the inherited symbol and establish a new one -(eval-when (compile load eval) - (shadow 'require)) - -(defmacro require (&rest args) - (cond ((null args) - (error "missing argument <filename> !")) - ((not (stringp (car args))) - (error "(require ~S): expected <filename> !" (car args))) - (t `(LET ((FILENAME (STRINGIFY ',(car args)))) - (DO-REQUIRE FILENAME))))) - -(defun do-require (filename) - (let ((file (find-file filename))) - (unless (member file *included-files* :test #'equalp) - (push file *included-files*) - (info "~&Loading module ~S..." filename) - (watched-load file :echo t) - (info "~&Finished loading module ~S.~%" filename)))) - -#| -(defun do-require (filename) - (let ((file (find-file filename))) - (unless (member file *included-files* :test #'equalp) - (push file *included-files*) - (info "~&Loading module ~S..." filename) - (let ((*standard-output* (make-string-output-stream))) - (handler-case - (load file :verbose nil :echo t) -; (stream-error (cond) -; (step -; (progn -; (oops* -; (simple-condition-format-string cond) -; (simple-condition-format-arguments cond)) -; (exit)) -; ) -; ) - (error (condition) - (info "~&~%~A~%" ";;;;;;;;;;;;;;;;;;;;;;;;") - (info "~A~%" ";; ERROR SECTION START") - (info "~%~A~%" (get-output-stream-string *standard-output*)) - (info "~%~A~%" ";; ERROR SECTION END") - (info "~A~%~%" ";;;;;;;;;;;;;;;;;;;;;;;;") - (oops* (simple-condition-format-string condition) - (simple-condition-format-arguments condition)) - (error-exit)) - ) - ) - (info "~&Finished loading module ~S.~%" filename)))) -|# -;; line 802 "intface.nw" -(defun find-file (filename) - (let ((file (parse-namestring filename))) - (when (equal (file-namestring file) "") - (error "~S is not a valid filename !" filename)) - (let ((found (some #'(lambda (path) - (and (probe-file (append-pathnames path file)))) - *load-paths*))) - (or found (error "Could not find file ~S !" filename))))) -;; line 813 "intface.nw" -(defvar *wl-fmt* "~&~%Error in line ~S:~%~A~%") -(defun watched-load (filename - &key - (print *load-print*) - (if-does-not-exist t) - echo) - (let ((stream (open (setq filename (pathname filename)) - :direction - #+CLISP :input-immutable - #-CLISP :input - :element-type - #+CLISP 'string-char - #-CLISP 'base-char - :if-does-not-exist nil)) - (lineno 1)) - (if stream - (let* ((load-stream (make-string-output-stream)) - (input-stream (if echo - (make-echo-stream stream load-stream) - stream - )) - (*load-pathname* (if (pathnamep filename) filename nil)) - (*load-truename* (if (pathnamep filename) (truename filename) nil)) - (*package* *package*) ; *PACKAGE* binden - (*readtable* *readtable*) ; *READTABLE* binden - (end-of-file "EOF")) ; einmaliges Objekt - ;;(setq sys::*load-input-stream* input-stream) - (block nil - (unwind-protect - (tagbody weiter - (let* ((obj - (handler-case (read input-stream nil end-of-file) - (error (cond) - (when echo - (let* ((str (get-output-stream-string load-stream)) - (cnt (count #\Newline str))) - (info *wl-fmt* (+ cnt lineno) str) - (oops* (simple-condition-format-string cond) - (simple-condition-format-arguments cond)) - (error-exit)))))) - (str (get-output-stream-string load-stream)) - (cnt (count #\Newline str))) - (incf lineno cnt) - (when (eql obj end-of-file) - (return-from nil)) - (setq obj - (multiple-value-list - (cond ((compiled-function-p obj) (funcall obj)) - ;;(compiling (funcall (compile-form obj nil nil nil nil nil))) - (t (handler-case (eval obj) - (error (cond) - (info *wl-fmt* lineno str) - (oops* (simple-condition-format-string cond) - (simple-condition-format-arguments cond)) - (error-exit))) - (get-output-stream-string load-stream) - )))) - (when print (when obj (print (first obj)))) - ) - (go weiter) - ) - (close stream) (close input-stream) - ) ) - t) - (if if-does-not-exist - (error "A file with name ~A does not exist" filename) - nil) - ) )) -;; line 891 "intface.nw" -(defmacro searchpath (&rest args) - (cond ((null args) - (error "missing argument <pathlist> !")) - ((stringp (car args)) - `(SET-SEARCHPATH-BY-STRING ,(car args))) - ((listp args) - `(SET-SEARCHPATH ',(car args))))) - -(defun set-searchpath-by-string (searchpath-str) - (set-searchpath (string-to-searchlist searchpath-str))) -;; line 913 "intface.nw" -(defun string-to-searchlist (str) - (let ((paths '()) - pos) - (nreverse - (loop (when (equalp str "") - (return (push :default paths))) - (setq pos (position #+UNIX #\: - #+OS/2 #\; - #+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-old/src/index.lsp b/Build/source/utils/xindy-old/src/index.lsp deleted file mode 100644 index 82a02b6a7b0..00000000000 --- a/Build/source/utils/xindy-old/src/index.lsp +++ /dev/null @@ -1,1332 +0,0 @@ -;; line 835 "index.nw" -;; $Id: index.nw,v 1.31 1997/03/26 16:18:37 kehr Exp $ - -(lisp:defpackage "INDEX") -(lisp:in-package "INDEX") -(lisp:provide "index") - -#+CLISP (lisp:require "base") -#+CLISP (lisp:require "locref") -#+CLISP (lisp:require "idxstyle") - -(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-old/src/locref.lsp b/Build/source/utils/xindy-old/src/locref.lsp deleted file mode 100644 index 428b629e910..00000000000 --- a/Build/source/utils/xindy-old/src/locref.lsp +++ /dev/null @@ -1,556 +0,0 @@ -;; line 360 "locref.nw" -;; $Id: locref.nw,v 1.29 1997/03/26 16:18:53 kehr Exp $ - -(lisp:defpackage "LOCREF") -(lisp:in-package "LOCREF") -(lisp:provide "locref") - -#+CLISP (lisp:require "base") - -(eval-when (compile load eval) - #-CLISP (lisp:require "base") - (lisp:use-package "BASE") - #+(and :XP CLISP) (lisp:use-package "XP") - (lisp:use-package "CLOS")) - -;; line 251 "basetype.nw" -;; $Id: basetype.nw,v 1.17 1997/03/26 16:18:47 kehr Exp $ - -;; line 110 "basetype.nw" -(defgeneric prefix-match (str object)) -;; line 114 "basetype.nw" -(defclass basetype () - ((name :initarg :name) - (base-alphabet :initarg :base-alphabet))) -;; line 142 "basetype.nw" -(defclass alphabet (basetype) - ((symbols :initarg :symbols))) - -(defun make-alphabet (name symbols) - (make-instance 'alphabet :name name :symbols symbols - :base-alphabet (calculate-base-alphabet symbols))) - -(defmethod make-copy ((alph alphabet) new-name) - (make-instance 'alphabet - :name new-name - :symbols (get-symbols alph) - :base-alphabet (get-base-alphabet alph))) -;; line 163 "basetype.nw" -(defun calculate-base-alphabet (list-of-strings) - (sort (remove-duplicates - (apply #'nconc - (mapcar #'(lambda (str) - (coerce str 'list)) - list-of-strings))) - #'char<)) -;; line 183 "basetype.nw" -(defmethod prefix-match ((str string) (alph alphabet)) - (multiple-value-bind (matched-string rest-string order-num) - (prefix-match-stringlist str (get-symbols alph)) - (values matched-string rest-string order-num))) - -(defun prefix-match-stringlist (pattern list-of-str) - (let* ((matched-string "") - (rest-string pattern) - (ordnum-of-max-match nil) - (len-max-match 0) - (strlen (length pattern))) - (do ((ordnum 0 (1+ ordnum)) - (string-list list-of-str (cdr string-list))) - ((endp string-list)) - (let ((len-curr-match (string/= pattern (car string-list)))) - (when (null len-curr-match) (setq len-curr-match strlen)) - (when (> len-curr-match len-max-match) - (setq ordnum-of-max-match ordnum) - (setq len-max-match len-curr-match) - (setq rest-string (subseq pattern len-curr-match)) - (setq matched-string - (subseq (car string-list) 0 len-curr-match))))) - (values matched-string rest-string ordnum-of-max-match))) -;; line 227 "basetype.nw" -(defclass enumeration (basetype) - ()) - -(defun make-enumeration (enum-class name base-alphabet) - (make-instance enum-class - :name name - :base-alphabet base-alphabet)) - -(defmethod make-copy ((enum enumeration) new-name) - (make-instance (class-name (class-of enum)) - :name new-name - :base-alphabet (get-base-alphabet enum))) - -;; line 257 "basetype.nw" -(eval-when (compile load eval) - -;; line 120 "basetype.nw" -(export '(basetype prefix-match get-name get-base-alphabet)) -;; line 157 "basetype.nw" -(export '(alphabet make-alphabet get-symbols make-copy)) -;; line 242 "basetype.nw" -(export '(enumeration make-enumeration)) -;; line 259 "basetype.nw" - ) -;; line 493 "locclass.nw" -;; $Id: locclass.nw,v 1.21 1997/03/26 16:18:49 kehr Exp $ - -;; line 67 "locclass.nw" -(defclass location-class () - ((name :type string :initarg :name) - (ordnum :type number :initform (gen-next-loccls-ordnum)))) -;; line 87 "locclass.nw" -(defparameter *curr-loccls-ordnum* 0) - -(defun gen-next-loccls-ordnum () - (incf *curr-loccls-ordnum*)) -;; line 106 "locclass.nw" -(defclass layered-location-class (location-class) - ((layers :initarg :layers) - (hierdepth :initarg :hierdepth))) -;; line 125 "locclass.nw" -(defclass standard-location-class (layered-location-class) - ((join-length :initarg :join-length))) - -(defun make-standard-location-class (name layers join-length hierdepth) - (make-instance 'standard-location-class - :name name :layers layers - :join-length join-length :hierdepth hierdepth)) -;; line 135 "locclass.nw" -(defmacro joining-allowed-p (loccls) - `(SLOT-VALUE ,loccls 'JOIN-LENGTH)) -;; line 144 "locclass.nw" -(defun checked-make-standard-location-class (name layers join-layers - &optional (hierdepth 0)) - (make-standard-location-class name layers join-layers hierdepth)) -;; line 163 "locclass.nw" -(defclass var-location-class (layered-location-class) - ()) - -(defun make-var-location-class (name layers hierdepth) - (make-instance 'var-location-class - :name name :layers layers :hierdepth hierdepth)) -;; line 172 "locclass.nw" -(defun checked-make-var-location-class (name layers &optional (hierdepth 0)) - (make-var-location-class name layers hierdepth)) -;; line 189 "locclass.nw" -(defclass loccls-layer () - ((basetype :initarg :basetype))) - -(defun make-loccls-layer (basetype) - (make-instance 'loccls-layer :basetype basetype)) -;; line 206 "locclass.nw" -(defmethod prefix-match ((locstring string) - (layer loccls-layer)) - (prefix-match locstring (get-basetype layer))) -;; line 220 "locclass.nw" -(defclass loccls-separator () - ((separator :initarg :separator))) - -(defun make-loccls-separator (separator) - (make-instance 'loccls-separator :separator separator)) -;; line 246 "locclass.nw" -(defmethod prefix-match ((locstring string) - (separator loccls-separator)) - (let* ((sepstr (get-separator separator)) - (seplen (length sepstr)) - (match-len (string/= sepstr locstring))) - (if (or (null match-len) (eql seplen match-len)) - (values locstring (subseq locstring seplen) t) - (values nil nil nil)))) -;; line 273 "locclass.nw" -(defclass crossref-location-class (location-class) - ((target :initarg :target))) -;; line 299 "locclass.nw" -(defclass verified-crossref-location-class (crossref-location-class) - ()) - -(defun make-verified-crossref-location-class (name) - (make-instance 'verified-crossref-location-class :name name)) -;; line 319 "locclass.nw" -(defclass unverified-crossref-location-class (crossref-location-class) - ()) - -(defun make-unverified-crossref-location-class (name) - (make-instance 'unverified-crossref-location-class :name name)) - -;; line 374 "locclass.nw" -(defgeneric perform-match (locstring locclass)) -;; line 402 "locclass.nw" -(defmethod perform-match ((locstring string) - (loccls standard-location-class)) - (let ((layer-list '()) - (ordnum-list '()) - (give-up nil) - (matched-string nil) - (rest-string nil) - (ordnum nil)) - (do ((layers (get-layers loccls) (cdr layers))) - ((or give-up - (let ((empty-string (= 0 (length locstring))) - (empty-list (endp layers))) - (cond ((and empty-string empty-list) t) - ((or empty-string empty-list) (setq give-up t)) - (t nil))))) - (let ((curr-layer (car layers))) - (multiple-value-setq (matched-string rest-string ordnum) - (prefix-match locstring curr-layer)) - (cond ((eq ordnum nil) (setq give-up t)) - ((numberp ordnum) - (setq locstring rest-string) - (setq layer-list - (cons matched-string layer-list)) - (setq ordnum-list (cons ordnum ordnum-list))) - (t (setq locstring rest-string))) - )) - (if (not give-up) - (values (nreverse layer-list) (nreverse ordnum-list)) - (values nil nil)))) -;; line 446 "locclass.nw" -(defmethod perform-match ((locstring string) - (loccls var-location-class)) - (let ((layer-list '()) - (ordnum-list '()) - (give-up nil) - (matched-string nil) - (rest-string nil) - (ordnum nil)) - (do ((layers (get-layers loccls) (cdr layers))) - ((or give-up - (let ((empty-string (= 0 (length locstring))) - (empty-list (endp layers))) - (cond (empty-string t) - (empty-list (setq give-up t)) - (t nil))))) - (let ((curr-layer (car layers))) - (multiple-value-setq (matched-string rest-string ordnum) - (prefix-match locstring curr-layer)) - (cond ((eq ordnum nil) (setq give-up t)) - ((numberp ordnum) - (setq locstring rest-string) - (setq layer-list - (cons matched-string layer-list)) - (setq ordnum-list (cons ordnum ordnum-list))) - (t (setq locstring rest-string))) - )) - (if (not give-up) - (values (nreverse layer-list) (nreverse ordnum-list)) - (values nil nil)))) -;; line 482 "locclass.nw" -;; FIXME (do we need this) -;;(defmethod perform-match ((locstring string) -;; (loccls crossref-location-class)) -;; t) - -;; line 507 "locclass.nw" -(eval-when (compile load eval) - -;; line 94 "locclass.nw" -(export '(location-class perform-match - get-name get-ordnum set-ordnum ordnum)) -;; line 112 "locclass.nw" -(export '(layered-location-class)) -;; line 150 "locclass.nw" -(export '(standard-location-class checked-make-standard-location-class - get-join-length set-join-length - joining-allowed-p join-length)) -;; line 177 "locclass.nw" -(export '(var-location-class checked-make-var-location-class)) -;; line 197 "locclass.nw" -(export '(loccls-layer make-loccls-layer - get-basetype get-markup)) -;; line 228 "locclass.nw" -(export '(loccls-separator make-loccls-separator - get-separator get-markup)) -;; line 278 "locclass.nw" -(export '(crossref-location-class get-target)) -;; line 307 "locclass.nw" -(export '(verified-crossref-location-class - make-verified-crossref-location-class)) -;; line 327 "locclass.nw" -(export '(unverified-crossref-location-class - make-unverified-crossref-location-class)) -;; line 183 "locref.nw" -(export '(crossref-location-reference create-cross-reference)) -;; line 215 "locref.nw" -(export 'build-location-reference) -;; line 509 "locclass.nw" - ) -;; line 56 "locref.nw" -(defclass location-reference () - ((locclass :initarg :locclass) - (attribute :initarg :attribute))) -;; line 78 "locref.nw" -(defclass layered-location-reference (location-reference) - ((layers :initarg :layers) - (locref-string :initarg :string :type string) - (ordnums :initarg :ordnums) - (catattr :initarg :catattr) - (state :initarg :state) - (rangeattr :initform 'nil) - (origin :initform 'nil) - (subrefs :initform '() :type list))) - -;; line 95 "locref.nw" -(defun make-layered-location-reference (&key (string "") - (layers '()) (ordnums '()) - (catattr nil) (locclass nil) - (attribute nil) (virtual nil)) - (make-instance 'layered-location-reference - :string string - :layers layers - :ordnums ordnums - :catattr catattr - :locclass locclass - :attribute attribute - :state (if virtual 'locref-state-virtual - 'locref-state-normal))) -;; line 116 "locref.nw" -(defmacro state-normal-p (locref) - `(EQL 'LOCREF-STATE-NORMAL (SLOT-VALUE ,locref 'STATE))) - -(defmacro state-virtual-p (locref) - `(EQL 'LOCREF-STATE-VIRTUAL (SLOT-VALUE ,locref 'STATE))) - -(defmacro state-deleted-p (locref) - `(EQL 'LOCREF-STATE-DELETED (SLOT-VALUE ,locref 'STATE))) - -(defun set-state-normal (locref) - (set-state 'locref-state-normal locref) - locref) - -(defun set-state-virtual (locref) - (set-state 'locref-state-virtual locref) - locref) - -(defun set-state-deleted (locref) - (set-state 'locref-state-deleted locref) - locref) -;; line 139 "locref.nw" -(defmacro rangeattr-open-p (attr) - `(EQL ,attr :RANGEATTR-OPEN)) - -(defmacro rangeattr-close-p (attr) - `(EQL ,attr :RANGEATTR-CLOSE)) - -(defmacro set-rangeattr-open (locref) - `(SETF (SLOT-VALUE ,locref 'RANGEATTR) :RANGEATTR-OPEN)) - -(defmacro set-rangeattr-close (locref) - `(SETF (SLOT-VALUE ,locref 'RANGEATTR) :RANGEATTR-CLOSE)) -;; line 241 "locref.nw" -(defclass category-attribute () - ((name :initarg :name) - (catattr-grp-ordnum :initarg :ordnum) - (sort-ordnum :initform 0) - (processing-ordnum :initform 0) - (last-in-group :initarg :type))) - -(defun make-category-attribute (attr-name) - (make-instance 'category-attribute :name attr-name)) -;; line 174 "locref.nw" -(defclass crossref-location-reference (location-reference) - ((target :initarg :target))) - -(defun create-cross-reference (loccls target attribute) - (make-instance 'crossref-location-reference - :locclass loccls :target target :attribute attribute)) -;; line 201 "locref.nw" -(defmethod build-location-reference ((locclass layered-location-class) - (locref-str string) - (catattr category-attribute) - attribute) - (multiple-value-bind (layers ordnums) - (perform-match locref-str locclass) - (and layers ordnums - (make-layered-location-reference - :locclass locclass :layers layers - :ordnums ordnums :catattr catattr - :attribute attribute :string locref-str)))) -;; line 288 "locref.nw" -(defun locref-class< (locref-1 locref-2) - (declare (inline)) - (< (get-ordnum (get-locclass locref-1)) - (get-ordnum (get-locclass locref-2)))) - -(defun locref-class= (locref-1 locref-2) - (declare (inline)) - (eql (get-locclass locref-1) (get-locclass locref-2))) -;; line 301 "locref.nw" -(defmacro locref-ordnum< (ordnum-list-1 ordnum-list-2) - `(COND - ((EQUAL ,ordnum-list-1 ,ordnum-list-2) NIL) - (T (DO ((REST-1 ,ordnum-list-1 (CDR REST-1)) - (REST-2 ,ordnum-list-2 (CDR REST-2))) - ((OR (ENDP REST-1) (ENDP REST-2) - (/= (FIRST REST-1) (FIRST REST-2))) - (COND ((ENDP REST-1) T) - ((ENDP REST-2) NIL) - (T (< (FIRST REST-1) (FIRST REST-2))))))))) - -(defmacro locref-ordnum= (ordnum-list-1 ordnum-list-2) - `(EQUAL ,ordnum-list-1 ,ordnum-list-2)) -;; line 320 "locref.nw" -#| -FIXME -(defun locref< (locref-1 locref-2) - (cond ((locref-class= locref-1 locref-2) - (locref-ordnum< locref-1 locref-2)) - (t (locref-class< locref-1 locref-2)))) -|# - -(defmethod locref= ((locref-1 crossref-location-reference) - (locref-2 layered-location-reference)) - nil) - -(defmethod locref= ((locref-1 layered-location-reference) - (locref-2 crossref-location-reference)) - nil) - -(defmethod locref= ((locref-1 crossref-location-reference) - (locref-2 crossref-location-reference)) - (and (locref-class= locref-1 locref-2) - (equal (get-target locref-1) (get-target locref-2)))) - -(defmethod locref= ((locref-1 layered-location-reference) - (locref-2 layered-location-reference)) - (and (locref-class= locref-1 locref-2) - (eql (get-catattr locref-1) (get-catattr locref-2)) - (locref-ordnum= (get-ordnums locref-1) (get-ordnums locref-2)) - (eql (get-rangeattr locref-1) (get-rangeattr locref-2)))) - -;; line 391 "locref.nw" -(eval-when (compile load eval) - -;; line 62 "locref.nw" -(export 'location-reference) -;; line 153 "locref.nw" -(export '(layered-location-reference - make-layered-location-reference - get-layers set-layers layers - get-ordnums set-ordnums ordnums - get-subrefs set-subrefs subrefs - get-catattr catattr - get-rangeattr rangeattr - get-locref-string string - get-origin set-origin - state - state-normal-p state-virtual-p state-deleted-p - set-state-normal set-state-virtual set-state-deleted - set-rangeattr-open set-rangeattr-close - rangeattr-open-p rangeattr-close-p)) -;; line 257 "locref.nw" -(export '(category-attribute make-category-attribute - get-name catattr-grp-ordnum - get-catattr-grp-ordnum set-catattr-grp-ordnum - get-sort-ordnum set-sort-ordnum - get-processing-ordnum set-processing-ordnum - get-last-in-group set-last-in-group - get-type set-type - get-markup set-markup)) -;; line 350 "locref.nw" -(export '(locref-class< locref-class= - locref-ordnum< locref-ordnum= - locref=)) -;; line 393 "locref.nw" - ) - -;; line 521 "locclass.nw" -#+:XP -(set-pprint-dispatch 'location-class - #'(lambda (s loccls) - (pprint-logical-block - (s nil :prefix "{" :suffix "}") - (write (get-name loccls) :stream s) - (write-string ":" s) - (write (get-ordnum loccls) :stream s)))) - -#+:XP -(set-pprint-dispatch 'layered-location-class - #'(lambda (s loccls) - (pprint-logical-block - (s nil :prefix "{" :suffix "}") - (write (get-name loccls) :stream s) - (write-string ":" s) - (write (get-ordnum loccls) :stream s) - (mapc #'(lambda (x) - (write-string " " s) - (pprint x s)) - (get-layers loccls))))) - -#+:XP -(set-pprint-dispatch 'loccls-layer - #'(lambda (s layer) - (pprint-logical-block - (s nil :prefix "<" :suffix ">") - (pprint (get-basetype layer) s)))) - -#+:XP -(set-pprint-dispatch 'loccls-separator - #'(lambda (s sep) - (pprint-logical-block - (s nil :prefix "<" :suffix ">") - (write (get-separator sep) :stream s)))) -;; line 406 "locref.nw" -#+:XP -(defun pprint-layered-location-reference (s locref) - (pprint-logical-block - (s nil :prefix "[" :suffix "]") - (cond ((state-normal-p locref) (write-string "Nor:" s)) - ((state-virtual-p locref) (write-string "Vir:" s)) - (t (write-string "Del:" s))) - (cond ((rangeattr-open-p (get-rangeattr locref)) (write-string "OPEN:" s)) - ((rangeattr-close-p (get-rangeattr locref)) (write-string "CLOSE:" s))) - (write-string "\"" s) - (write-string (get-locref-string locref) s) - (write-string "\"=" s) - (write (get-layers locref) :stream s) - (write-string "=" s) - (write (get-ordnums locref) :stream s) - (write-string ";" s) - (pprint-newline :fill s) - (write (get-locclass locref) :stream s) - (write-string ";" s) - (pprint-newline :fill s) - (write (get-catattr locref) :stream s) - (when (get-origin locref) - (write-string "<-" s) - (write (get-catattr (get-origin locref)) :stream s)) - (pprint-newline :fill s) - (write (get-subrefs locref) :stream s) - )) - -#+:XP -(set-pprint-dispatch 'layered-location-reference - #'pprint-layered-location-reference) -;; line 440 "locref.nw" -#+:XP -(defun pprint-crossref-location-reference (s xref) - (pprint-logical-block - (s nil :prefix "[" :suffix "]") - (write (get-locclass xref) :stream s) - (write-string "->" s) - (write (get-target xref) :stream s) - )) - -#+:XP -(set-pprint-dispatch 'crossref-location-reference - #'pprint-crossref-location-reference) -;; line 455 "locref.nw" -#+:XP -(set-pprint-dispatch 'category-attribute - #'(lambda (s catattr) - (write-string "`" s) - (write-string (get-name catattr) s) - (write-string "'" s))) - -;; line 380 "locref.nw" -(defvar *RCS-Identifier* '( -;; line 263 "basetype.nw" -("basetype" . "$Id: basetype.nw,v 1.17 1997/03/26 16:18:47 kehr Exp $") -;; line 513 "locclass.nw" -("locclass" . "$Id: locclass.nw,v 1.21 1997/03/26 16:18:49 kehr Exp $") -;; line 397 "locref.nw" -("locref" . "$Id: locref.nw,v 1.29 1997/03/26 16:18:53 kehr Exp $") -;; line 380 "locref.nw" - )) diff --git a/Build/source/utils/xindy-old/src/markup.lsp b/Build/source/utils/xindy-old/src/markup.lsp deleted file mode 100644 index 4cb73feb508..00000000000 --- a/Build/source/utils/xindy-old/src/markup.lsp +++ /dev/null @@ -1,1291 +0,0 @@ -;; line 1154 "markup.nw" -;; $Id: markup.nw,v 1.24 1997/03/26 16:18:58 kehr Exp $ - -(lisp:defpackage "MARKUP") -(lisp:in-package "MARKUP") -(lisp:provide "markup") -#+CLISP (lisp:require "base") -#+CLISP (lisp:require "locref") -#+CLISP (lisp:require "idxstyle") -#+CLISP (lisp:require "index") - -(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:require "version") - (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 "xindy run time engine: ~A, version ~A~%" - *xindy-platform* xindy::*xindy-rte-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 - custom:*foreign-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-core-version* *xindy-platform*)) -;; line 232 "startup.nw" - ) diff --git a/Build/source/utils/xindy-old/src/version.lsp b/Build/source/utils/xindy-old/src/version.lsp deleted file mode 100644 index 7148b65dfa6..00000000000 --- a/Build/source/utils/xindy-old/src/version.lsp +++ /dev/null @@ -1,11 +0,0 @@ -;; $Id$ -*- Lisp -*- -;; ------------------------------------------------------------ -;; version identification of xindy kernel -;; src/version.lsp. - -(in-package :xindy-version) -(lisp:provide "version") - -(export '*xindy-kernel-version*) - -(defparameter *xindy-kernel-version* "2.3") |