diff options
Diffstat (limited to 'Build/source/utils/xindy/src/idxstyle.lsp')
| -rw-r--r-- | Build/source/utils/xindy/src/idxstyle.lsp | 2131 |
1 files changed, 2131 insertions, 0 deletions
diff --git a/Build/source/utils/xindy/src/idxstyle.lsp b/Build/source/utils/xindy/src/idxstyle.lsp new file mode 100644 index 00000000000..299d513aad9 --- /dev/null +++ b/Build/source/utils/xindy/src/idxstyle.lsp @@ -0,0 +1,2131 @@ +;; 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 #\; + 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" + ) |