summaryrefslogtreecommitdiff
path: root/Build/source/utils/xindy/xindy-src/src/idxstyle.lsp
diff options
context:
space:
mode:
Diffstat (limited to 'Build/source/utils/xindy/xindy-src/src/idxstyle.lsp')
-rw-r--r--Build/source/utils/xindy/xindy-src/src/idxstyle.lsp2127
1 files changed, 0 insertions, 2127 deletions
diff --git a/Build/source/utils/xindy/xindy-src/src/idxstyle.lsp b/Build/source/utils/xindy/xindy-src/src/idxstyle.lsp
deleted file mode 100644
index 2a561aee7f9..00000000000
--- a/Build/source/utils/xindy/xindy-src/src/idxstyle.lsp
+++ /dev/null
@@ -1,2127 +0,0 @@
-;; line 289 "idxstyle.nw"
-;; $Id: idxstyle.nw,v 1.19 1997/03/26 16:18:23 kehr Exp $
-;;
-
-(lisp:defpackage "IDXSTYLE")
-(lisp:in-package "IDXSTYLE")
-(lisp:provide "idxstyle")
-
-#+CLISP (lisp:require "base")
-#+CLISP (lisp:require "locref")
-#+CLISP (lisp:require "ordrules")
-
-(eval-when (compile load eval)
- (lisp:use-package "CLOS")
- (lisp:use-package "COMMON-LISP")
- #+CLISP (lisp:use-package "EXT")
- #+(and :XP CLISP) (lisp:use-package "XP")
- #-CLISP (lisp:require "base")
- #-CLISP (lisp:require "locref")
- (lisp:use-package "BASE")
- (lisp:use-package "LOCREF")
-
-;; line 472 "intface.nw"
-(eval-when (eval load compile)
- (when (find-package "ORDRULES")
- (pushnew :ORDRULES *features*)))
-;; line 306 "idxstyle.nw"
- ;; see submodule intface
- )
-
-;; line 78 "idxstyle.nw"
-(defparameter *indexstyle* nil)
-(defparameter *indexstyle-readtable* (copy-readtable))
-(defparameter *included-files* '())
-(defvar *load-paths* "")
-(defparameter *default-load-paths* *load-paths*)
-
-(defparameter *default-minimum-range-length* 2)
-(defparameter *default-locref-hierdepth* 0)
-
-;; line 1151 "intface.nw"
-;; $Id: intface.nw,v 1.30 1997/10/20 11:25:09 kehr Exp $
-
-;; line 1016 "intface.nw"
-;;; $Id: intface.nw,v 1.30 1997/10/20 11:25:09 kehr Exp $
-;;;----------------------------------------------------------------------
-
-;;;
-;;; util-lib LISP Utitlity Library
-;;;
-;;; (history at end)
-
-
-;(provide 'util-lib)
-;(in-package 'util-lib)
-
-(defvar whole)
-(eval-when (compile load eval)
- (export '(destructuring-switch-bind &switch whole)))
-
-(defmacro destructuring-switch-bind (lambdalist expr . body)
- "Similar to 'destructuring-bind' but also allows switch options at the
-end of LAMBDALIST with the following syntax:
-
- &switch { var | (var key [defval]) | (var ({ key }*) [defval]) }*
-
-In all cases VAR will be accessible in BODY as a variable.
-
-If only VAR is specified, it is bound to the keyword with the same
-name, if that keyword occured in EXPR. Otherwise it is bound to NIL.
-
-If both a VAR and KEY were specified, VAR will be bound to KEY, if KEY
-occured in EXPR and to NIL otherwise.
-
-If VAR and a list of KEYs were specified, VAR will be bound to the
-first KEY, which occured in EXPR. If none of the KEYS occured within
-EXPR, VAR will be bound to NIL.
-
-If DEFVAL was specified, variable will be bound to DEFVAL instead of
-NIL in cases where no switch keyword was found in EXPR.
-"
-
- (let* ((switchlist (member '&switch lambdalist))
-
- ;; 'remove' switches from lambdalist
- (lambdalist (ldiff lambdalist switchlist))
-
- ;; drop &switch keyword
- (switches (when switchlist (cdr switchlist)))
-
- ;; construct bindings for each switch and collect valid
- ;; keywords in 'switchkeys'
- (switchkeys '())
- (bindings
- (mapcar
- #'(lambda (spec)
- (cond
-
- ;; spec simply consists of VAR
- ((symbolp spec)
- (let ((key (intern (symbol-name spec) 'keyword)))
- (push key switchkeys)
- `(,spec (FIND ,key <DESTRUCTURING-SWITCH-FORM>))
- ))
-
- ;; spec is (VAR form)
- ((and (listp spec) (>= (list-length spec) 2))
- (let ((var (first spec))
- (keyspec (second spec))
- (defval (when (cddr spec) (third spec))))
- (cond
- ;; spec is (VAR (KEY1 KEY2 ...))
- ((listp keyspec)
- `(,var
- (COND
- ,@(mapcar
- #'(lambda (key)
- (push key switchkeys)
- `((FIND ,key <DESTRUCTURING-SWITCH-FORM>)
- ,key))
- keyspec)
- (T ,defval))))
-
- ;; spec is (VAR KEY)
- (t
- (push keyspec switchkeys)
- ` (,var (OR
- (FIND ,keyspec <DESTRUCTURING-SWITCH-FORM>)
- ,defval)))
- )))
-
- ;; illegal spec
- (t (error "~A is not a valid switch specifier." spec))
- ))
- switches))
- )
-
- ;; construct the expansion form
- ` (LET ((<DESTRUCTURING-SWITCH-FORM> ,expr))
- (LET ,bindings
- (HANDLER-CASE
- (DESTRUCTURING-BIND ,lambdalist
- (SET-DIFFERENCE-KEEP-ORIGINAL-ORDER
- <DESTRUCTURING-SWITCH-FORM>
- ',switchkeys)
- ,@body)
- (ERROR (COND)
- (DECLARE (IGNORE COND))
- (ERROR "~&Syntax Error in ~S." WHOLE)
- )
- )
- )
- )
- ))
-
-(defun set-difference-keep-original-order (set1 set2)
- (mapcan #'(lambda (elt)
- (unless (member elt set2)
- (list elt)))
- set1))
-
-#|
-(destructuring-switch-bind (name &rest args &key foo bar
- &switch
- on ; simple form
- (started :start)
- (speed (:fast :slow))
- (off :turn-off :turn-on) ; with switch key
- (choose (:one :two :three) :three))
- '(width :foo 5 :bar 7 :on :turn-off :one)
- (list name foo bar args on started speed off choose))
-|#
-;; line 111 "intface.nw"
-(eval-when (compile load eval)
- (defun stringify (name)
- (declare (inline))
- (etypecase name
- (symbol (symbol-name name))
- (string name)
- (number (write-to-string name)))))
-
-(defun list-of-strings-p (x)
- (cond ((not (listp x)) nil)
- ((every #'(lambda (elt)
- (or (stringp elt) (symbolp elt) (numberp elt)))
- x))))
-;; line 136 "intface.nw"
-(defun make-well-formed-list (attr-list)
- (mapcar #'(lambda (x)
- (cond ((null x)
- (error "empty lists are not allowed !"))
- ((or (symbolp x) (stringp x) (numberp x))
- (list (stringify x)))
- ((listp x)
- (map-to-strings x))))
- attr-list))
-
-(defun map-to-strings (slist)
- (mapcar #'(lambda (x)
- (cond ((null x)
- (error "empty lists are not allowed !"))
- ((or (symbolp x) (stringp x) (numberp x))
- (stringify x))
- ((listp x)
- (error "nesting level too deep !"))
- (t (error "~S is not a string !" x))))
- slist))
-;; line 185 "intface.nw"
-(defun c-string-reader (stream char)
- (declare (ignore char))
- (let ((ch nil)
- (str (make-array 32
- :element-type
- #+CLISP 'string-char
- #-CLISP 'base-char
- :adjustable t
- :fill-pointer 0)))
- (loop
- (setq ch (read-char stream t #\Newline t))
- (case ch
- (#\" (let ((nextch (read-char-no-hang stream t #\Newline t)))
- (when nextch
- (unread-char nextch stream)
- (case nextch
- (#\Newline)
- (#\t)
- (#\Space)
- (#\))
- (t (nraw "~&Possible read-error due to ill-formed string \"~A\" ~S"
- str *))))
- (return str)))
- (#\~ (setq ch (read-char stream t #\Newline t))
- (case ch
- (#\n (vector-push-extend #\Newline str))
- (#\t (vector-push-extend #\Tab str))
- (#\b (vector-push-extend (character 1) str))
- (#\e (vector-push-extend (character 255) str))
- (t (vector-push-extend ch str))))
- (t (vector-push-extend ch str))))))
-
-(set-macro-character #\" #'c-string-reader nil *indexstyle-readtable*)
-
-#|
-(let ((x #\Null))
- (loop for i from 1 to 255
- do (progn (print (character i))
- (when (char>= x (character i))
- (print "Whee!"))
- (setq x (character i)))))
-|#
-;; line 254 "intface.nw"
-(defmacro define-alphabet (&whole whole &optional name string-list)
- (cond
-;; line 239 "intface.nw"
-((null name)
- (error "missing argument <name> in `~S' !" whole))
-((not (or (symbolp name) (stringp name)))
- (error "~S is not a symbol or a string in `~S' !" name whole))
-;; line 256 "intface.nw"
- ((not (listp string-list))
- (error "missing argument <string-list> !"))
- ((not (list-of-strings-p string-list))
- (error "~S is not a list of strings" string-list))
- (t `(LET ((NAME (STRINGIFY ',name)))
- (WHEN (LOOKUP-BASETYPE *indexstyle* NAME)
- (NRAW "redefining alphabet `~S'" NAME))
- (ADD *indexstyle* (MAKE-ALPHABET NAME ',string-list))))))
-
-(defmacro define-alphabet* (&whole whole &optional name string-list)
- (cond
-;; line 239 "intface.nw"
-((null name)
- (error "missing argument <name> in `~S' !" whole))
-((not (or (symbolp name) (stringp name)))
- (error "~S is not a symbol or a string in `~S' !" name whole))
-;; line 267 "intface.nw"
- ((not (listp string-list))
- (error "missing argument <string-list> !"))
- (t (let ((scar (car string-list)))
- (if (and (symbolp scar) (fboundp scar))
- `(LET ((NAME (STRINGIFY ',name))
- (STRING-LIST ,string-list)) #| evaluates string-list |#
- (UNLESS (LIST-OF-STRINGS-P STRING-LIST)
- (ERROR "~S is not a list of strings" STRING-LIST))
- (WHEN (LOOKUP-BASETYPE *indexstyle* NAME)
- (NRAW "redefining alphabet `~S'" NAME))
- (ADD *indexstyle* (MAKE-ALPHABET NAME STRING-LIST))))))))
-;; line 284 "intface.nw"
-(defmacro define-enumeration (&whole
- whole
- &optional
- name prefix-match-func base-alphabet)
- (cond
-;; line 239 "intface.nw"
-((null name)
- (error "missing argument <name> in `~S' !" whole))
-((not (or (symbolp name) (stringp name)))
- (error "~S is not a symbol or a string in `~S' !" name whole))
-;; line 289 "intface.nw"
- ((null prefix-match-func)
- (error "missing argument <prefix-match-function> !"))
- (t (let* ((name (stringify name))
- (symbol (make-symbol
- (concatenate 'string "ENUMERATION-" name))))
- `(LET () #| PROGN instead of LET () yields a runtime error !? |#
- (IF (LOOKUP-BASETYPE *indexstyle* ,name)
- (NRAW "redefining alphabet `~S'" ,name)
- (PROGN
- (DEFCLASS ,symbol (ENUMERATION) ())
- (ADD *indexstyle*
- (MAKE-ENUMERATION ',symbol ,name ,base-alphabet))))
- (DEFMETHOD PREFIX-MATCH ((STR STRING) (ENUM ,symbol))
- (FUNCALL ,prefix-match-func STR)))))))
-;; line 312 "intface.nw"
-(defmacro define-location-class (&whole whole &rest args)
- (destructuring-switch-bind (name
- layer-list
- &key
- (min-range-length *default-minimum-range-length*)
- (hierdepth 0) ;no hierarchies are to be formed
- &switch
- (var :var))
- args
- (cond
- ((null name)
- (error "missing argument <name> in~%~S" whole))
- ((null layer-list)
- (error "missing argument <layer-list> in~%~S" whole))
- ;;((not (list-of-strings-p layer-list))
- ;; (error "~S is not a list of strings in~%~S" layer-list whole))
- ((not (numberp hierdepth))
- (error "~S is not a number! in~%~S" hierdepth whole))
- ((not (or (numberp min-range-length)
- (eql 'none min-range-length)))
- (error "~S must be a number or the keyword `none' in~%~S"
- min-range-length whole))
- (t (when (eql 'none min-range-length)
- (setq min-range-length 0))
- `(LET ((NAME (STRINGIFY ',name))
- (LAYERS (BUILD-LOCCLASS-LAYERS ',layer-list ',whole)))
- ;;(GOL T "~&define-location-class: ~S" LAYERS)
- (COND ((LOOKUP-CROSSREF-CLASS *indexstyle* NAME)
- (OOPS "replacing cross-reference-class `~S' is not allowed !"
- NAME))
- (t (WHEN (LOOKUP-LOCATION-CLASS *indexstyle* NAME)
- (NRAW "redefining location-reference-class `~S' !" NAME))
- (ADD *indexstyle*
- ,(if var
- `(CHECKED-MAKE-VAR-LOCATION-CLASS NAME LAYERS
- ,hierdepth)
- `(CHECKED-MAKE-STANDARD-LOCATION-CLASS NAME LAYERS
- ,min-range-length ,hierdepth))))
- ))))))
-;; line 354 "intface.nw"
-(defun build-locclass-layers (layers whole)
- (let ((res-list '()))
- (loop
- ;;(gol t "~&build-locclass-layers: ~S" layers)
- (when (endp layers) (return (nreverse res-list)))
- (cond ((eql :sep (car layers))
- (setq layers (cdr layers))
- (if (endp layers)
- (error "Reached end of list in~%~S" whole)
- (push (make-loccls-separator (stringify (car layers)))
- res-list)))
- (t (let* ((layer (stringify (car layers)))
- (basetype (lookup-basetype *indexstyle* layer)))
- (if basetype
- (push (make-loccls-layer basetype) res-list)
- (error "Unknown basetype ~S in~%~S" layer whole)))))
- (setq layers (cdr layers)))))
-;; line 377 "intface.nw"
-(defmacro define-crossref-class (&whole whole &rest args)
- (destructuring-switch-bind (name
- &switch (verified :unverified))
- args
- (cond
-;; line 239 "intface.nw"
-((null name)
- (error "missing argument <name> in `~S' !" whole))
-((not (or (symbolp name) (stringp name)))
- (error "~S is not a symbol or a string in `~S' !" name whole))
-;; line 382 "intface.nw"
- (t `(LET ((NAME (STRINGIFY ',name)))
- (cond ((LOOKUP-LOCATION-CLASS *indexstyle* NAME)
- (OOPS "replacing location-reference-class `~S' is not allowed !"
- NAME))
- (t (WHEN (LOOKUP-CROSSREF-CLASS *indexstyle* NAME)
- (NRAW "redefining crossref-location-class `~S'" NAME))
- (ADD *indexstyle*
- ,(if verified
- `(MAKE-UNVERIFIED-CROSSREF-LOCATION-CLASS NAME)
- `(MAKE-VERIFIED-CROSSREF-LOCATION-CLASS NAME))))))))))
-;; line 398 "intface.nw"
-(defmacro define-location-class-order (olist)
- (cond ((not (listp olist))
- (error "missing argument <list> !"))
- ((not (list-of-strings-p olist))
- (error "~S is not a list of strings" olist))
- (t `(LET ((CTR 1))
- (MAPC #'(LAMBDA (NAME)
- (LET* ((NEW-NAME (STRINGIFY NAME))
- (LOCCLS
- (CDR (LOOKUP-LOCATION-CLASS *indexstyle*
- NEW-NAME))))
- (INCF CTR)
- (COND (LOCCLS (SET-ORDNUM CTR LOCCLS))
- (t (OOPS "unknown location-class `~S'"
- NEW-NAME)))))
- ',olist)))))
-;; line 423 "intface.nw"
-(defmacro define-attributes (&whole whole &optional attr-list)
- (cond ((null attr-list)
- (error "missing argument <attribute-list> in~&~S" whole))
- (t (let* ((wf-attr-list (make-well-formed-list attr-list))
- (plain-list (apply #'concatenate 'list wf-attr-list))
- )
- `(PROGN
- (MAPCAR
- #'(LAMBDA (CATATTR)
- (IF (LOOKUP-CATATTR *indexstyle* CATATTR)
- (NRAW "ignoring redefinition of attribute ~S in~&~S"
- CATATTR ',whole)
- (ADD *indexstyle*
- (MAKE-CATEGORY-ATTRIBUTE CATATTR))))
- ',plain-list)
- (INITIALIZE-CATEGORY-ATTRIBUTES ',wf-attr-list *indexstyle*))
- ))))
-;; line 488 "intface.nw"
-#+:ORDRULES
-(defmacro merge-rule (&whole whole &rest args)
- (destructuring-switch-bind (pattern
- replacement
- &switch
- (again :again)
- (string :string)
- (extended-regexp :eregexp)
- (basic-regexp :bregexp))
- args
- (cond ((null pattern)
- (error "missing argument <pattern> !"))
- ((or (and string extended-regexp) (and string basic-regexp)
- (and extended-regexp basic-regexp))
- (error "~&Only one of (:string :bregexp :eregexp) allowed in:~&~S !"
- whole))
- ((null replacement)
- (error "~&Missing argument <replacement> in:~&~S!" whole))
- (t `(PROGN
- (ORDRULES:ADD-KEYWORD-MERGE-RULE ,pattern ,replacement
- ,(if again 1 0)
- ,(cond (string 1)
- (basic-regexp 2)
- (extended-regexp 3)
- (t 0)))
- (FLUSH-ORDRULES-MESSAGE-BUFFER))))))
-
-#-:ORDRULES
-(defmacro merge-rule (&rest args)
- (declare (ignore args))
- (oops "merge-rule not supported! ignoring definition"))
-;; line 525 "intface.nw"
-#+:ORDRULES
-(defparameter *sort-rule-orientations*
- '(forward forward forward forward
- forward forward forward forward))
-
-#+:ORDRULES
-(defmacro define-sort-rule-orientations (&whole whole &rest args)
- (destructuring-switch-bind (&optional
- (orientations *sort-rule-orientations*))
- args
- (unless (every #'(lambda (run)
- (member run '(forward backward)))
- orientations)
- (error "~&Elements of ~S must be one of {forward,backward}!"
- orientations))
- `(PROGN
- (SETQ *SORT-RULE-ORIENTATIONS* ',orientations)
- (ORDRULES:INITIALIZE (LENGTH *SORT-RULE-ORIENTATIONS*))
- (FLUSH-ORDRULES-MESSAGE-BUFFER))))
-
-#+:ORDRULES
-(defmacro define-rule-set (&whole whole &rest args)
- (destructuring-bind (&optional
- name
- &key
- inherit-from
- rules)
- args
- (cond
-;; line 239 "intface.nw"
-((null name)
- (error "missing argument <name> in `~S' !" whole))
-((not (or (symbolp name) (stringp name)))
- (error "~S is not a symbol or a string in `~S' !" name whole))
-;; line 554 "intface.nw"
- ((not (listp rules))
- (error "missing argument <rules-list> !"))
- (t `(LET ((RS (MAKE-RULE-SET ',name ',inherit-from ',rules)))
- (MAPC #'(LAMBDA (INH-NAME)
- (INHERIT-RULE-SET RS (LOOKUP-RULE-SET *INDEXSTYLE*
- INH-NAME)))
- ',inherit-from)
- (ADD-RULE-SET *INDEXSTYLE* RS))))))
-
-#-:ORDRULES
-(defmacro define-rule-set (&rest args)
- (declare (ignore args))
- (oops "define-rule-sets not supported! ignoring definition"))
-
-#+:ORDRULES
-(defmacro use-rule-set (&whole whole &rest args)
- ;; FIXME: if we use destructuring-switch-bind-here an error occurs
- (destructuring-bind (&key
- run
- rule-set)
- args
- (cond ((not (integerp run))
- (error "incorrect argument <run> !"))
- ((not rule-set)
- (error "missing argument <rule-set> !"))
- ((not (or (listp rule-set)
- (stringp rule-set)))
- (error "wrong argument to <rule-set> !"))
- (t `(INSTANTIATE-RULE-SET ,run ,rule-set)))))
-
-#-:ORDRULES
-(defmacro use-rule-set (&rest args)
- (declare (ignore args))
- (oops "use-rule-sets not supported! ignoring definition"))
-
-#+:ORDRULES
-(defmacro sort-rule (&whole whole &rest args)
- (destructuring-switch-bind (pattern
- replacement
- &key
- (run 0)
- &switch
- (again :again)
- (string :string)
- (extended-regexp :eregexp)
- (basic-regexp :bregexp))
- args
- (cond ((null pattern)
- (error "missing argument <pattern> !"))
- ((or (< run 0) (>= run (length *sort-rule-orientations*)))
- (error "~&Argument of :run must be in the interval [0..~A]!"
- (length *sort-rule-orientations*)))
- ((or (and string extended-regexp) (and string basic-regexp)
- (and extended-regexp basic-regexp))
- (error "~&Only one of (:string :bregexp :eregexp) allowed in:~&~S !"
- whole))
- ((null replacement)
- (error "missing argument <replacement> !"))
- (t `(PROGN
- (ORDRULES:ADD-KEYWORD-SORT-RULE ,run ,pattern ,replacement
- ,(if again 1 0)
- ,(cond (string 1)
- (basic-regexp 2)
- (extended-regexp 3)
- (t 0)))
- (FLUSH-ORDRULES-MESSAGE-BUFFER))))))
-
-#-:ORDRULES
-(defmacro define-sort-rule-orientations (&rest args)
- (declare (ignore args))
- (oops "define-sort-rule-orientations not supported! ignoring definition"))
-
-#-:ORDRULES
-(defmacro sort-rule (&rest args)
- (declare (ignore args))
- (oops "sort-rule not supported! ignoring definition"))
-
-(defun flush-ordrules-message-buffer ()
- #+:ORDRULES
- (when (and *mappings-trace* ordrules::*message-logging*)
- (gol t "~A" ordrules::*message-buffer*)
- (setq ordrules::*message-buffer-ptr* 0)))
-;; line 696 "intface.nw"
-(defmacro define-letter-group
- (&whole whole name &key prefixes before after)
- (cond
-;; line 239 "intface.nw"
-((null name)
- (error "missing argument <name> in `~S' !" whole))
-((not (or (symbolp name) (stringp name)))
- (error "~S is not a symbol or a string in `~S' !" name whole))
-;; line 699 "intface.nw"
- ((and before
- (not (lookup-letter-group-definition *indexstyle* before)))
- (error "~S does not name a letter group in~%~S" before whole))
- ((and after
- (not (lookup-letter-group-definition *indexstyle* after)))
- (error "~S does not name a letter group in~%~S" after whole))
- ((not (list-of-strings-p prefixes))
- (error "argument <prefixes> is not a list of strings in~%~S"
- whole))
- (t `(LET ()
- (ADD-LETTER-GROUPS *INDEXSTYLE*
- ,name ',(or prefixes (list name))
- :BEFORE ,before :AFTER ,after)))))
-;; line 718 "intface.nw"
-(defmacro define-letter-groups (&whole whole &optional letter-groups)
- (cond ((not (list-of-strings-p letter-groups))
- (error "~S is not a list of strings in~%~S" letter-groups whole))
- (t `(LET ()
- (ADD-LETTER-GROUPS *INDEXSTYLE*
- ,(car letter-groups) ',(list (car letter-groups)))
- ,@(let ((last (car letter-groups)))
- (mapcar #'(lambda (letter-group)
- (prog1
- `(ADD-LETTER-GROUPS *INDEXSTYLE*
- ,letter-group ',(list letter-group)
- :AFTER ,last)
- (setq last letter-group)))
- (cdr letter-groups)))))))
-;; line 650 "intface.nw"
-(defmacro merge-to (&whole whole &rest args)
- (destructuring-switch-bind (from to &switch drop)
- args
- (let ((from-attr (lookup-catattr *indexstyle* from))
- (to-attr (lookup-catattr *indexstyle* to)))
- (cond ((not from-attr)
- (nraw "`~S' is not a known attribute in:~&~A" from whole))
- ((not to-attr)
- (nraw "`~S' is not a known attribute in:~&~A" to whole))
- (t (if drop
- `(ADD-DROP-IF-MERGED-RULE *INDEXSTYLE*
- ',from-attr ',to-attr)
- `(ADD-MERGE-RULE *INDEXSTYLE*
- ',from-attr ',to-attr)))))))
-;; line 740 "intface.nw"
-;;; we remove the inherited symbol and establish a new one
-(eval-when (compile load eval)
- (shadow 'require))
-
-(defmacro require (&rest args)
- (cond ((null args)
- (error "missing argument <filename> !"))
- ((not (stringp (car args)))
- (error "(require ~S): expected <filename> !" (car args)))
- (t `(LET ((FILENAME (STRINGIFY ',(car args))))
- (DO-REQUIRE FILENAME)))))
-
-(defun do-require (filename)
- (let ((file (find-file filename)))
- (unless (member file *included-files* :test #'equalp)
- (push file *included-files*)
- (info "~&Loading module ~S..." filename)
- (watched-load file :echo t)
- (info "~&Finished loading module ~S.~%" filename))))
-
-#|
-(defun do-require (filename)
- (let ((file (find-file filename)))
- (unless (member file *included-files* :test #'equalp)
- (push file *included-files*)
- (info "~&Loading module ~S..." filename)
- (let ((*standard-output* (make-string-output-stream)))
- (handler-case
- (load file :verbose nil :echo t)
-; (stream-error (cond)
-; (step
-; (progn
-; (oops*
-; (simple-condition-format-string cond)
-; (simple-condition-format-arguments cond))
-; (exit))
-; )
-; )
- (error (condition)
- (info "~&~%~A~%" ";;;;;;;;;;;;;;;;;;;;;;;;")
- (info "~A~%" ";; ERROR SECTION START")
- (info "~%~A~%" (get-output-stream-string *standard-output*))
- (info "~%~A~%" ";; ERROR SECTION END")
- (info "~A~%~%" ";;;;;;;;;;;;;;;;;;;;;;;;")
- (oops* (simple-condition-format-string condition)
- (simple-condition-format-arguments condition))
- (error-exit))
- )
- )
- (info "~&Finished loading module ~S.~%" filename))))
-|#
-;; line 802 "intface.nw"
-(defun find-file (filename)
- (let ((file (parse-namestring filename)))
- (when (equal (file-namestring file) "")
- (error "~S is not a valid filename !" filename))
- (let ((found (some #'(lambda (path)
- (and (probe-file (append-pathnames path file))))
- *load-paths*)))
- (or found (error "Could not find file ~S !" filename)))))
-;; line 813 "intface.nw"
-(defvar *wl-fmt* "~&~%Error in line ~S:~%~A~%")
-(defun watched-load (filename
- &key
- (print *load-print*)
- (if-does-not-exist t)
- echo)
- (let ((stream (open (setq filename (pathname filename))
- :direction
- #+CLISP :input-immutable
- #-CLISP :input
- :element-type
- #+CLISP 'string-char
- #-CLISP 'base-char
- :if-does-not-exist nil))
- (lineno 1))
- (if stream
- (let* ((load-stream (make-string-output-stream))
- (input-stream (if echo
- (make-echo-stream stream load-stream)
- stream
- ))
- (*load-pathname* (if (pathnamep filename) filename nil))
- (*load-truename* (if (pathnamep filename) (truename filename) nil))
- (*package* *package*) ; *PACKAGE* binden
- (*readtable* *readtable*) ; *READTABLE* binden
- (end-of-file "EOF")) ; einmaliges Objekt
- ;;(setq sys::*load-input-stream* input-stream)
- (block nil
- (unwind-protect
- (tagbody weiter
- (let* ((obj
- (handler-case (read input-stream nil end-of-file)
- (error (cond)
- (when echo
- (let* ((str (get-output-stream-string load-stream))
- (cnt (count #\Newline str)))
- (info *wl-fmt* (+ cnt lineno) str)
- (oops* (simple-condition-format-string cond)
- (simple-condition-format-arguments cond))
- (error-exit))))))
- (str (get-output-stream-string load-stream))
- (cnt (count #\Newline str)))
- (incf lineno cnt)
- (when (eql obj end-of-file)
- (return-from nil))
- (setq obj
- (multiple-value-list
- (cond ((compiled-function-p obj) (funcall obj))
- ;;(compiling (funcall (compile-form obj nil nil nil nil nil)))
- (t (handler-case (eval obj)
- (error (cond)
- (info *wl-fmt* lineno str)
- (oops* (simple-condition-format-string cond)
- (simple-condition-format-arguments cond))
- (error-exit)))
- (get-output-stream-string load-stream)
- ))))
- (when print (when obj (print (first obj))))
- )
- (go weiter)
- )
- (close stream) (close input-stream)
- ) )
- t)
- (if if-does-not-exist
- (error "A file with name ~A does not exist" filename)
- nil)
- ) ))
-;; line 891 "intface.nw"
-(defmacro searchpath (&rest args)
- (cond ((null args)
- (error "missing argument <pathlist> !"))
- ((stringp (car args))
- `(SET-SEARCHPATH-BY-STRING ,(car args)))
- ((listp args)
- `(SET-SEARCHPATH ',(car args)))))
-
-(defun set-searchpath-by-string (searchpath-str)
- (set-searchpath (string-to-searchlist searchpath-str)))
-;; line 913 "intface.nw"
-(defun string-to-searchlist (str)
- (let ((paths '())
- pos)
- (nreverse
- (loop (when (equalp str "")
- (return (push :default paths)))
- (setq pos (position #+UNIX #\:
- #+OS/2 #\;
- #+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"
- )