;; line 835 "index.nw" ;; $Id: index.nw,v 1.31 1997/03/26 16:18:37 kehr Exp $ (lisp:defpackage "INDEX") (lisp:in-package "INDEX") (lisp:provide "index") #+CLISP (lisp:require "base") #+CLISP (lisp:require "locref") #+CLISP (lisp:require "idxstyle") (eval-when (compile load eval) (lisp:use-package "CLOS") #+(and :XP CLISP) (lisp:use-package "XP") #-CLISP (lisp:require "base") #-CLISP (lisp:require "locref") #-CLISP (lisp:require "idxstyle") (lisp:use-package "BASE") (lisp:use-package "LOCREF") (lisp:use-package "IDXSTYLE")) ;; The following construct must be separated since the definition of ;; the *feature* :ORDRULES was added via loading the package ;; "idxstyle" but is only active *after* reading the whole SEXP. (eval-when (compile load eval) #+:ORDRULES (use-package "ORDRULES")) ;; line 986 "idxentry.nw" ;; $Id: idxentry.nw,v 1.29 1997/03/27 17:17:25 kehr Exp $ ;; line 1002 "idxentry.nw" (defvar *number-of-indexentries*) (defvar *current-number*) ;; line 1007 "idxentry.nw" (defvar *percentage-list*) (defvar *processing-percentage-list*) (defun print-rest-of-percentages (plist) (dolist (percent plist) (when (<= (cdr percent) 100) (print-percent percent)))) (defun print-percent (percent-cons) (info " [~A%]" (cdr percent-cons))) ;; line 85 "idxentry.nw" (defclass index-entry () ((main-key :initarg :main-key) (merge-key :initarg :merge-key) (sort-key :initarg :sort-key) (print-key :initarg :print-key) (locrefs :initarg :locrefs) (idxclass :initarg :idxclass) (subentries :initform '()))) (defun make-index-entry (&key (main-key '()) (merge-key '()) (sort-key '()) (print-key '()) (locrefs '()) (idxclass nil) &allow-other-keys) (make-instance 'index-entry :main-key main-key :merge-key merge-key :sort-key sort-key :print-key print-key :locrefs locrefs :idxclass idxclass)) ;; line 108 "idxentry.nw" (defvar *currently-processed-indexentry*) ;; line 116 "idxentry.nw" (defmacro add-location-reference-to-indexentry (idxent locref) `(PROGN (UNLESS (SOME #'(LAMBDA (LREF) (LOCREF= ,locref LREF)) (GET-LOCREFS ,idxent)) (SET-LOCREFS (CONS ,locref (GET-LOCREFS ,idxent)) ,idxent)) ,idxent)) ;; line 249 "idxentry.nw" (defun convert-sublists-to-group-objects (list-of-sublists object-type &key (initializer-func nil)) (mapcar #'(lambda (sublist) (let ((locref-grp (make-locref-group object-type sublist))) (if initializer-func (funcall initializer-func locref-grp) locref-grp))) list-of-sublists)) ;; line 267 "idxentry.nw" (defun convert-sublists-to-specialized-groups (list-of-sublists convert-func &optional initializer-func) (mapcar #'(lambda (sublist) (let ((locref-grp (make-locref-group (funcall convert-func sublist) sublist))) (if initializer-func (funcall initializer-func locref-grp) locref-grp))) list-of-sublists)) ;; line 292 "idxentry.nw" (defclass locref-group () ((members :initarg :members))) (defun make-locref-group (group-class members) (make-instance group-class :members members)) (defgeneric process-group (group-object indexclass)) ;; line 322 "idxentry.nw" (defclass locref-class-group (locref-group) ((locclass :initform 'nil))) ;; line 327 "idxentry.nw" (defclass crossref-class-group (locref-group) ((locclass :initform 'nil))) ;; line 333 "idxentry.nw" (defun process-indexentry (idxent) (setq *currently-processed-indexentry* idxent) (when (>= (incf *current-number*) (caar *processing-percentage-list*)) (print-percent (pop *processing-percentage-list*))) (set-locrefs (convert-sublists-to-specialized-groups (split-list #'(lambda (locref) (get-ordnum (get-locclass locref))) (get-locrefs idxent) :sortfunc #'<) #'(lambda (sublist) (typecase (car sublist) (layered-location-reference 'locref-class-group) (crossref-location-reference 'crossref-class-group) (t (error "internal error in `process-indexentry'")))) #'(lambda (locref-cls-grp) (set-locclass (get-locclass (car (get-members locref-cls-grp))) locref-cls-grp) locref-cls-grp)) idxent) (mapc #'(lambda (locref-cls-grp) (process-group locref-cls-grp *indexstyle*)) (get-locrefs idxent)) idxent) ;; line 899 "idxentry.nw" (defmacro take-first (list) `(AND ,list (LIST (CAR ,list)))) (defun tree-location-references (locref-list max-depth &optional (curr-depth 1)) (cond ((or (endp locref-list) #| nothing more to do |# (> curr-depth max-depth)) #| we reached the end |# locref-list) (t (let ((locref-slist (split-list #'(lambda (locref) (car (get-ordnums locref))) locref-list :sortfunc #'<))) (mapcar #'(lambda (sublist) (let* ((locref (car sublist)) (ordnums (get-ordnums locref))) (if (= 1 (length ordnums)) (progn #| length = 1 |# (set-subrefs (sort-locrefs (tree-location-references (remove-first-layers (cdr sublist)) max-depth (1+ curr-depth))) locref) locref) (let #| length > 1 |# ((new-locref (make-layered-location-reference :layers (take-first (get-layers locref)) :ordnums (take-first (get-ordnums locref)) :locclass (get-locclass locref) :catattr (get-last-in-group (get-catattr locref)) ))) (set-subrefs (sort-locrefs (tree-location-references (remove-first-layers sublist) max-depth (1+ curr-depth))) new-locref) new-locref)))) locref-slist))))) ;; line 947 "idxentry.nw" (defun remove-first-layers (locref-list) (declare (inline)) (mapc #'(lambda (locref) (typecase locref (layered-location-reference (set-layers (cdr (get-layers locref)) locref) (set-ordnums (cdr (get-ordnums locref)) locref)) (location-range (let ((first (get-first locref)) (last (get-last locref))) (set-layers (cdr (get-layers locref)) locref) (set-ordnums (cdr (get-ordnums locref)) locref) (set-layers (cdr (get-layers first)) first) (set-ordnums (cdr (get-ordnums first)) first) (set-layers (cdr (get-layers last)) last) (set-ordnums (cdr (get-ordnums last)) last) )))) locref-list) locref-list) ;; line 973 "idxentry.nw" (defun sort-locrefs (locref-list) #+:ASSERT! (assert! (listp locref-list)) (sort locref-list #'(lambda (locref-1 locref-2) (locref-ordnum< (get-ordnums locref-1) (get-ordnums locref-2))))) ;; line 370 "idxentry.nw" (defmethod process-group ((locref-cls-grp locref-class-group) (idxcls indexclass)) #+:XP (when *locref-trace* (pprint-locref-group *logging-stream* locref-cls-grp "Inital location-refrence group:")) (apply-substitution-and-merge-rules locref-cls-grp idxcls) #+:XP (when *locref-trace* (pprint-locref-group *logging-stream* locref-cls-grp "After subst- and merge-to-rules:")) (build-ranges-in-locref-class-group locref-cls-grp idxcls) #+:XP (when *locref-trace* (pprint-locref-group *logging-stream* locref-cls-grp "After build-ranges:")) (remove-virtual-locrefs locref-cls-grp) #+:XP (when *locref-trace* (pprint-locref-group *logging-stream* locref-cls-grp "After remove virtuals:")) (separate-into-catattr-groups locref-cls-grp) #+:XP (when *locref-trace* (pprint-locref-group *logging-stream* locref-cls-grp "After separate attr-groups:")) locref-cls-grp) ;; line 531 "idxentry.nw" (defmethod apply-substitution-and-merge-rules ((locref-cls-grp locref-class-group) (idxcls indexclass)) (let ((locref-same-ordnum-grps (split-same-locrefs (get-members locref-cls-grp)))) (set-members (mapcan #'(lambda (locref-same-ordnum-grp) (apply-merge-rules idxcls (apply-substitution-rules idxcls locref-same-ordnum-grp))) locref-same-ordnum-grps) locref-cls-grp)) locref-cls-grp) ;; line 553 "idxentry.nw" (defun split-same-locrefs (locrefs) #+ASSERT! (assert! (listp locrefs)) (split-list #'(lambda (locref) (get-ordnums locref)) locrefs :sortfunc #'(lambda (locref-ordnum-1 locref-ordnum-2) (locref-ordnum< locref-ordnum-1 locref-ordnum-2)) )) ;; line 569 "idxentry.nw" (defmethod apply-substitution-rules ((idxcls indexclass) (locrefs list)) (let ((substitute-locref (get-substitution-subst-hook idxcls))) (delete-if #'null (mapcar #'(lambda (test-locref) (cond ((some #'(lambda (against-locref) (substitutable-p idxcls test-locref against-locref)) locrefs) (funcall substitute-locref test-locref)) (t test-locref))) locrefs)))) ;; line 590 "idxentry.nw" (defmethod substitutable-p ((idxcls indexclass) (test-locref layered-location-reference) (against-locref layered-location-reference)) (cond ((eql test-locref against-locref) nil) ((and (state-normal-p against-locref) (relation-p (get-implicit-subst-rules idxcls) (get-catattr against-locref) (get-catattr test-locref)))) (t nil))) ;; line 638 "idxentry.nw" (defmethod apply-merge-rules ((idxcls indexclass) (locrefs list)) (let ((merge-rules (get-merge-rules idxcls)) (drop-if-merged-rules (get-drop-if-merged-rules idxcls))) (nconc locrefs (mapcan #'(lambda (locref) (mapcan #'(lambda (catattr) (let ((new-locref (make-layered-location-reference :virtual t :layers (get-layers locref) :ordnums (get-ordnums locref) :catattr catattr :locclass (get-locclass locref) :attribute (get-attribute locref) :string (get-locref-string locref) ))) (when (relation-p drop-if-merged-rules (get-catattr locref) catattr) (set-origin locref new-locref)) (list new-locref))) (relation-set merge-rules (get-catattr locref)))) locrefs)))) ;; line 721 "idxentry.nw" (defun build-ranges-in-locref-class-group (locref-cls-grp idxcls) (let ((locref-same-catattr-grps (split-list #'(lambda (locref) (get-catattr locref)) (get-members locref-cls-grp) :sortfunc #'(lambda (x y) (< (get-processing-ordnum x) (get-processing-ordnum y)))))) (set-members (mapcan #'(lambda (catattr-sublist) (let ((processed-locrefs (build-ranges catattr-sublist idxcls (get-locclass (car catattr-sublist))))) (when *locref-trace* (let ((*print-pretty* t)) (gol t "~&after build-ranges:") (pprint-newline :mandatory *logging-stream*) (pprint-newline :mandatory *logging-stream*) (write processed-locrefs :stream *logging-stream*))) (let ((s2 (mapcar #'(lambda (x) (post-process x #'set-state-deleted)) processed-locrefs))) (when *locref-trace* (let ((*print-pretty* t)) (gol t "~&after set-state-deleted:") (pprint-newline :mandatory *logging-stream*) (pprint-newline :mandatory *logging-stream*) (write s2 :stream *logging-stream*))) s2))) locref-same-catattr-grps) locref-cls-grp))) ;; line 396 "idxentry.nw" (defmethod process-group ((crossref-cls-grp crossref-class-group) (idxcls indexclass)) (let ((cross-references (get-members crossref-cls-grp))) (typecase (get-locclass (car cross-references)) (verified-crossref-location-class (mapc #'(lambda (xref) (let* ((target (get-target xref)) (merge-key-target #+:ORDRULES (gen-keyword-mergekey-list target) #-:ORDRULES target)) (unless (lookup-indexentry merge-key-target) (oops "Cross-reference-target ~S does not exist!" target)))) cross-references)) (unverified-crossref-location-class) (t (error "INTERNAL ERROR in process-group")))) crossref-cls-grp) ;; line 422 "idxentry.nw" (defun remove-virtual-locrefs (locref-cls-grp) (set-members (delete-if #'(lambda (object) (and (typep object 'location-reference) (state-virtual-p object))) (get-members locref-cls-grp)) locref-cls-grp)) ;; line 794 "idxentry.nw" (defclass category-attribute-group (locref-group) ((ordnum :initform 'nil))) (defun separate-into-catattr-groups (locref-cls-grp) (set-members (convert-sublists-to-group-objects (split-list #'(lambda (object) (get-catattr-grp-ordnum (get-catattr object))) (get-members locref-cls-grp) :sortfunc #'<) 'category-attribute-group) locref-cls-grp) (mapc #'(lambda (catattr-grp) (set-ordnum (get-catattr-grp-ordnum (get-catattr (car (get-members catattr-grp)))) catattr-grp) (set-members (sort (tree-location-references (get-members catattr-grp) (get-hierdepth (get-locclass locref-cls-grp))) #'(lambda (object-1 object-2) (let ((ordnum-1 (get-ordnums object-1)) (ordnum-2 (get-ordnums object-2))) (or (locref-ordnum< ordnum-1 ordnum-2) (and (locref-ordnum= ordnum-1 ordnum-2) (< (get-sort-ordnum (get-catattr object-1)) (get-sort-ordnum (get-catattr object-2)))))))) catattr-grp)) (get-members locref-cls-grp)) locref-cls-grp) #| (defun separate-into-catattr-groups-old-version (locref-cls-grp) (set-members (convert-sublists-to-group-objects (split-list #'(lambda (object) (get-catattr-grp-ordnum (get-catattr object))) #'< (get-members locref-cls-grp)) 'category-attribute-group) locref-cls-grp) (mapc #'(lambda (catattr-grp) (set-ordnum (get-catattr-grp-ordnum (get-catattr (car (get-members catattr-grp)))) catattr-grp) (set-members (sort (get-members catattr-grp) #'(lambda (object-1 object-2) (let ((ordnum-1 (get-ordnums object-1)) (ordnum-2 (get-ordnums object-2))) (or (locref-ordnum< ordnum-1 ordnum-2) (and (locref-ordnum= ordnum-1 ordnum-2) (< (get-sort-ordnum (get-catattr object-1)) (get-sort-ordnum (get-catattr object-2)))))))) catattr-grp)) (get-members locref-cls-grp)) locref-cls-grp) |# ;; line 992 "idxentry.nw" (eval-when (compile load eval) ;; line 127 "idxentry.nw" (export '(index-entry make-index-entry add-location-reference-to-indexentry)) ;; line 360 "idxentry.nw" (export '(locref-group get-members locref-class-group crossref-class-group get-locclass make-locref-group process-group process-indexentry)) ;; line 603 "idxentry.nw" (export '(process-group split-same-locrefs apply-substitution-rules substitutable-p)) ;; line 664 "idxentry.nw" (export '(apply-merge-rules)) ;; line 853 "idxentry.nw" (export '(category-attribute-group)) ;; line 1021 "idxentry.nw" (export '(*percentage-list* print-rest-of-percentages print-percent)) ;; line 994 "idxentry.nw" ) ;; line 594 "ranges.nw" ;; $Id: ranges.nw,v 1.11 1997/03/26 16:18:41 kehr Exp $ ;; line 68 "ranges.nw" (defclass location-range () ((length :initarg :length) (first :initarg :first) (last :initarg :last) (layers :initarg :layers) (ordnums :initarg :ordnums) (inner :initarg :inner) (locclass :initarg :locclass) (catattr :initarg :catattr) (subrefs :initform '()))) (defun make-location-range (&key length first last first-ordnum inner locclass) (make-instance 'location-range :length length :first first :last last :inner inner :ordnums first-ordnum :layers (get-layers first) :locclass locclass :catattr (get-catattr first))) ;; line 581 "ranges.nw" (defun ordnum-successor-p (ordnums-1 ordnums-2) (declare (inline)) (and ordnums-1 #|is there really something in it, or we are about to start?|# (equal (butlast ordnums-1) (butlast ordnums-2)) (equal (1+ (car (last ordnums-1))) (car (last ordnums-2))))) ;; line 143 "ranges.nw" (defmethod build-ranges ((locref-list list) (idxcls indexclass) (loccls var-location-class)) locref-list) ;; line 321 "ranges.nw" (defmacro newstat (s) `(setq new-state ,s)) (defmacro pushl () `(progn (setq curr-ordnum (get-ordnums locref)) (unless locref-stack (setq first-ordnum curr-ordnum) (setq first-locref locref)) (setq prev-ordnum curr-ordnum) (push locrefs locref-stack))) (defmacro pushone () `(progn (setq curr-ordnum (get-ordnums locref)) (unless locref-stack (setq first-ordnum curr-ordnum) (setq first-locref locref)) (setq prev-ordnum curr-ordnum) (push (list (car locrefs)) locref-stack))) (defmacro set-open-range () `(setq last-open-locref locref)) (defmacro keep () `(setq back-flag t)) (defmacro make-range () `(setq make-flag t)) ;; line 197 "ranges.nw" (defmethod build-ranges ((locref-list list) (idxcls indexclass) (loccls standard-location-class)) (let ((valid-list (mapcan #'(lambda (locref) (unless (state-deleted-p locref) (list locref))) locref-list))) (ifnot valid-list '() (ifnot (joining-allowed-p loccls) valid-list (let ((same-ordnum-list (split-same-locrefs valid-list)) ;; line 353 "ranges.nw" (locref-stack '()) (result-list '()) (state :START) (join-length (get-join-length loccls)) new-state open-p close-p open+close-p no-typ-p list-end make-flag back-flag locrefs locref last-open-locref first-locref first-ordnum prev-ordnum curr-ordnum ;; line 209 "ranges.nw" ) (loop ;; line 365 "ranges.nw" (setq locrefs (car same-ordnum-list)) (setq list-end (null locrefs)) (setq locref (car locrefs)) (setq open-p (find-if #'(lambda (locref) (rangeattr-open-p (get-rangeattr locref))) locrefs)) (setq close-p (find-if #'(lambda (locref) (rangeattr-close-p (get-rangeattr locref))) locrefs)) (setq open+close-p (and open-p close-p)) (setq no-typ-p (not (or open-p close-p))) ;; line 212 "ranges.nw" (ecase state (:START ;; line 230 "ranges.nw" (cond (list-end (return (apply #'nconc #| see note below for explanation |# (apply #'nconc result-list)))) (no-typ-p (newstat :READ) (pushl)) (open+close-p (newstat :READ) (pushone)) (open-p (newstat :OPEN-RANGE) (pushl) (set-open-range)) (close-p (warn-invalid-close locref) (newstat :START)) (t (error "INTERNAL-ERROR in build-ranges - :START"))) ;; line 213 "ranges.nw" ) (:READ ;; line 267 "ranges.nw" (if list-end (progn (newstat :START) (make-range)) (progn (setq curr-ordnum (get-ordnums locref)) (let ((succ-p (ordnum-successor-p prev-ordnum curr-ordnum))) (cond ((and succ-p no-typ-p) (pushl)) ((and succ-p open+close-p) (pushone)) ((or no-typ-p (not (and succ-p open-p))) (newstat :START) (keep) (make-range)) (open-p (newstat :OPEN-RANGE) (pushl) (set-open-range)) (close-p (warn-invalid-close locref) (newstat :READ)) (t (error "INTERNAL-ERROR in build-ranges - :READ")))))) ;; line 214 "ranges.nw" ) (:OPEN-RANGE ;; line 288 "ranges.nw" (cond (list-end ;; line 297 "ranges.nw" (warn (with-output-to-string (s) (format s "Found no :close-range matching an already opened one!~%") (format s "Location-reference is ~A in keyword ~A.~%" (get-locref-string last-open-locref) (get-main-key *currently-processed-indexentry*)) (format s "Maybe I lost some of the regular location-references.~%"))) ;; line 288 "ranges.nw" (newstat :START)) ((or no-typ-p open+close-p) (pushl)) (open-p ;; line 307 "ranges.nw" (warn (with-output-to-string (s) (format s "Found :open-range that was already opened!~%") (format s "Location-references are ~A and ~A in keyword ~A.~%" (get-locref-string last-open-locref) (get-locref-string locref) (get-main-key *currently-processed-indexentry*)) (format s "I'll continue and ignore this.~%"))) ;; line 291 "ranges.nw" (newstat :OPEN-RANGE)) (close-p (newstat :READ) (pushl)) (t (error "INTERNAL-ERROR in build-ranges - :OPEN-RANGE"))) ;; line 215 "ranges.nw" )) ;; line 402 "ranges.nw" (when make-flag (let ((range-len (- (car (last prev-ordnum)) (car (last first-ordnum))))) (if (>= range-len join-length) (push (list (list (make-location-range :first-ordnum first-ordnum :locclass loccls :inner locref-stack :first first-locref :last (caar locref-stack) :length range-len))) result-list) (push locref-stack result-list)) (setq locref-stack '()) (setq make-flag nil))) (if back-flag (setq back-flag nil) (setq same-ordnum-list (cdr same-ordnum-list))) (setq state new-state) ;; line 216 "ranges.nw" )))))) ;; line 241 "ranges.nw" (defun warn-invalid-close (locref) (warn (with-output-to-string (s) (format s "Found a :close-range in the index that wasn't opened before!~%") (format s "Location-reference is ~A in keyword ~A~%" (get-locref-string locref) (get-main-key *currently-processed-indexentry*)) (format s "I'll continue and ignore this.~%")))) ;; line 509 "ranges.nw" (defmethod post-process ((locrange location-range) (drop-function function)) (let ((locref-list (apply #'nconc (get-inner locrange)))) (cond ((>= (get-length locrange) (get-join-length (get-locclass locrange))) (mapc #'(lambda (locref) (let ((origin (get-origin locref))) (when origin (funcall drop-function origin)))) locref-list) ;;(set-inner '() locrange) locrange) (t locref-list)))) ;(defmethod post-process ((locref-list list) x) ; (declare (ignore x)) ; locref-list) (defmethod post-process ((locref location-reference) x) (declare (ignore x)) locref) ;; line 600 "ranges.nw" (eval-when (compile load eval) ;; line 92 "ranges.nw" (export '(location-range get-first get-last get-length)) ;; line 602 "ranges.nw" ) ;; line 88 "index.nw" (defparameter *index-entry-table* nil) #| faster access to the entry-table |# ;; line 69 "index.nw" (defconstant *all-hierarchy-layers* MOST-POSITIVE-FIXNUM) (defclass base-index () ((entry-table :initform (make-hash-table :test #'equal)) (entry-list :initform '()) (entries :initform '()) (idxclass :initarg :idxclass) (hierdepth :initform *all-hierarchy-layers*))) (defun make-base-index (idxclass) (make-instance 'base-index :idxclass idxclass)) ;; line 542 "index.nw" (defclass letter-group () ((members :initarg :members :type list) (group-definition :initarg :group-definition))) ;; line 555 "index.nw" (defun make-letter-group (members) (make-instance 'letter-group :members members :group-definition (match-letter-group *indexstyle* (car (get-sort-key (car members)))))) ;; line 273 "index.nw" (defun add-layered-locref-indexentry (&key (entry-table *index-entry-table*) (idxcls *indexstyle*) locref main-key (merge-key '()) (print-key '()) (open-range nil) (close-range nil) (catattr nil) (attribute nil)) #+:ASSERT! (assert! (and main-key locref)) (if (and open-range close-range) ;; line 320 "index.nw" (nraw "specification of both :open-range and :close-range is invalid! (ignored)") ;; line 285 "index.nw" (progn (when (or (not catattr) (string= catattr "")) (setq catattr "default")) (let ((catattr-obj (lookup-catattr idxcls catattr))) (if (not catattr-obj) (nraw "unknown attribute `~A'! (ignored)" catattr) (multiple-value-bind (num location-reference) (create-location-reference-from-string locref catattr-obj attribute) (when (eql 1 num) #| ; Only one vaild location-reference! Use #'eql and not #'= since we compare num against NIL, too. |# ;; line 359 "index.nw" #+:ORDRULES (unless merge-key (setq merge-key (gen-keyword-mergekey-list main-key))) #-:ORDRULES (unless merge-key (setq merge-key main-key)) ;; line 301 "index.nw" (cond (open-range (set-rangeattr-open location-reference)) (close-range (set-rangeattr-close location-reference))) (let ((old-entry (gethash merge-key entry-table))) (if old-entry (setf (gethash merge-key entry-table) (join-indexentries old-entry;;(gethash merge-key entry-table) main-key print-key location-reference)) (setf (gethash merge-key entry-table) (make-index-entry :main-key main-key :merge-key merge-key :print-key print-key :locrefs (list location-reference) :indexclass idxcls))))))))))) ;; line 324 "index.nw" (defun add-crossref-indexentry (&key (entry-table *index-entry-table*) (idxcls *indexstyle*) (merge-key '()) (print-key '()) main-key xref xref-class-name (attribute nil)) #+:ASSERT! (assert! (and main-key xref xref-class-name)) (unless xref-class-name (setq xref-class-name "default")) (let ((xref-class (cdr (lookup-crossref-class idxcls xref-class-name)))) (if (not xref-class) (nraw "unknown cross-reference-class `~A'! (ignored)~%" xref-class-name) (let ((cross-reference (create-cross-reference xref-class xref attribute))) (when cross-reference ;; line 359 "index.nw" #+:ORDRULES (unless merge-key (setq merge-key (gen-keyword-mergekey-list main-key))) #-:ORDRULES (unless merge-key (setq merge-key main-key)) ;; line 344 "index.nw" (let ((old-entry (gethash merge-key entry-table))) (if old-entry (setf (gethash merge-key entry-table) (join-indexentries old-entry ;;(gethash merge-key entry-table) main-key print-key cross-reference)) (setf (gethash merge-key entry-table) (make-index-entry :main-key main-key :merge-key merge-key :print-key print-key :locrefs (list cross-reference) :indexclass idxcls))))))))) ;; line 367 "index.nw" #+:ORDRULES (defun gen-keyword-mergekey-list (list-of-strings) #+ASSERT! (assert! (and (not (null list-of-strings)) (listp list-of-strings))) (let ((res (mapcar #'(lambda (str) (gen-keyword-mergekey str)) list-of-strings))) (flush-ordrules-message-buffer) res)) #+:ORDRULES (defun gen-keyword-sortkey-list (list-of-strings run) #+ASSERT! (assert! (and (not (null list-of-strings)) (listp list-of-strings) (<= 0 run) (run < 8))) (let ((res (mapcar #'(lambda (str) (gen-keyword-sortkey str run)) list-of-strings))) (flush-ordrules-message-buffer) res)) ;; line 398 "index.nw" (defun join-indexentries (idxent main-key print-key locref) (let ((old-main-key (get-main-key idxent)) (old-print-key (get-print-key idxent))) (unless old-main-key (set-main-key main-key idxent)) (set-print-key (mapcar #'(lambda (old curr) (or old curr)) old-print-key print-key) idxent) ;; (info "~&(join-indexentries :old-main-key ~S :old-print-key ~S :new-print-key ~S)" ;; old-main-key old-print-key (get-print-key idxent)) (add-location-reference-to-indexentry idxent locref))) ;; line 438 "index.nw" (defun create-location-reference-from-string (locref-str catattr attribute) (let* ((idxcls *indexstyle*)) (multiple-value-bind (num locref) (lookup-locref-cache idxcls locref-str) (if num #| something was found! |# (case num (0 ;; line 474 "index.nw" (nraw "location-reference ~S did not match any location-class! (ignored)" locref-str) ;; line 445 "index.nw" (values nil nil)) (1 (values 1 (copy-locref-from-template locref catattr attribute)) #| return its only member |#) (t ;; line 469 "index.nw" (nraw "location-reference ~S did match multiple location-classes! (taking first one)" locref-str) ;; line 449 "index.nw" (values num (copy-locref-from-template locref catattr attribute)) #| return a copy of the stored template |#)) (let ((locref-list (map-location-classes idxcls #'(lambda (idxcls loccls) (declare (ignore idxcls)) (build-location-reference loccls locref-str catattr attribute))))) (case (length locref-list) (0 ;; line 474 "index.nw" (nraw "location-reference ~S did not match any location-class! (ignored)" locref-str) ;; line 460 "index.nw" (add-locref-cache idxcls locref-str 0 nil)) (1 (add-locref-cache idxcls locref-str 1 (car locref-list)) #| return its only member |#) (t ;; line 469 "index.nw" (nraw "location-reference ~S did match multiple location-classes! (taking first one)" locref-str) ;; line 464 "index.nw" (add-locref-cache idxcls locref-str 1 (car locref-list)) #| return its first member |#))))))) ;; line 482 "index.nw" (defun copy-locref-from-template (locref catattr attribute) (declare (inline)) (make-layered-location-reference :catattr catattr :attribute attribute :string (get-locref-string locref) :locclass (get-locclass locref) :layers (copy-list (get-layers locref)) :ordnums (copy-list (get-ordnums locref)))) ;; line 727 "index.nw" (defun sort-indexentries (indexentries) #+:ASSERT! (assert! (listp indexentries)) (gol t "~&sort-indexentries: ~S" *sort-rule-orientations*) (sort indexentries #'(lambda (idxent-1 idxent-2) (multiple-value-bind (less-equal? equal?) (strlist<= (get-sort-key idxent-1) (get-sort-key idxent-2) (first *sort-rule-orientations*)) (if equal? (sort-other-runs (get-merge-key idxent-1) (get-merge-key idxent-2) (rest *sort-rule-orientations*) 1) less-equal?))))) ;; line 751 "index.nw" (defun sort-other-runs (merge-key-1 merge-key-2 orientations run) (gol t "~&sort-other-runs: ~S ~S ~S ~S." merge-key-1 merge-key-2 orientations run) (cond ((endp orientations) (nraw "Sort rules could not define exact order of key ~S." merge-key-1) nil) (t (let ((key-1 (mapcar #'(lambda (key) (gen-keyword-sortkey key run)) merge-key-1)) (key-2 (mapcar #'(lambda (key) (gen-keyword-sortkey key run)) merge-key-2))) (flush-ordrules-message-buffer) (multiple-value-bind (less-equal? equal?) (strlist<= key-1 key-2 (first orientations)) (if equal? (sort-other-runs merge-key-1 merge-key-2 (rest orientations) (1+ run)) less-equal?)))))) ;; line 782 "index.nw" (defun oriented-string (string orientation) (declare (inline)) (cond ((eql orientation 'forward) string) ((eql orientation 'backward) (reverse string)) (t (error "INDEX:ORIENTED-STRING wrong orientation!")))) ;; line 793 "index.nw" (defun strlist<= (slist-1 slist-2 orientation) (declare (inline)) (cond ((endp slist-1) (values t (endp slist-2))) ((endp slist-2) (values nil nil)) (t (let ((str-1 (oriented-string (first slist-1) orientation)) (str-2 (oriented-string (first slist-2) orientation))) (let ((pos (string/= str-1 str-2))) (if pos (let ((lt (string< str-1 str-2))) (if lt (values t nil) (values nil (string= str-1 str-2)))) (strlist<= (cdr slist-1) (cdr slist-2) orientation))))))) #| (strlist<= '("foo") '("foo") 'forward) (strlist<= '("fool") '("foo") 'forward) (strlist<= '("foo") '("fool") 'forward) (strlist<= '("foo") '("fool") 'backward) (strlist<= '("foo") '("foo" "bar") 'forward) (strlist<= '("foo" "bar") '("foo") 'forward) (strlist<= '("foo" "bar") '("foo") 'backward) |# #+OLDVER (defun strlist< (string-list-1 string-list-2) (declare (inline)) (do ((rest-1 string-list-1 (cdr rest-1)) (rest-2 string-list-2 (cdr rest-2))) ((or (endp rest-1) (endp rest-2) (string/= (first rest-1) (first rest-2))) (or (endp rest-1) (if (endp rest-2) 'nil (string< (first rest-1) (first rest-2))))))) ;; line 504 "index.nw" (defmethod process-index ((index base-index)) (let ((hash-list '())) (maphash #'(lambda (key idxentry) (declare (ignore key)) (setq hash-list (cons idxentry hash-list))) (get-entry-table index)) (set-entry-list hash-list index) (build-indexentry-tree index) (setq *number-of-indexentries* (length (get-entry-list index))) (setq *current-number* 0) (setq *percentage-list* (mapcar #'(lambda (percent) (cons (truncate (* (/ percent 100) *number-of-indexentries*)) percent)) ;; MOST-POSITIVE-FIXNUM acts as sentinel such that ;; we never run out of elements `(10 20 30 40 50 60 70 80 90 100 ,MOST-POSITIVE-FIXNUM))) (setq *processing-percentage-list* *percentage-list*) (mapc #'process-indexentry (get-entry-list index)) (print-rest-of-percentages *processing-percentage-list*) index)) ;; line 568 "index.nw" (defmethod build-indexentry-tree ((index base-index)) (let ((index-hierdepth (get-hierdepth index))) (gol t "~&~%Building indexentry-tree:~%") (gol t "Hierdepth of index is ~S~%~%" (if (= index-hierdepth most-positive-fixnum) :tree index-hierdepth)) (set-entries (build-indexentry-tree-recursive (get-entry-list index) index-hierdepth) index) (gol t "~&~%Forming letter-groups:~%") (let ((letter-groups (split-list #'(lambda (idxent) (get-ordnum (match-letter-group *indexstyle* (car (get-sort-key idxent))))) (get-entries index) :sortfunc #'<))) (set-entries (mapcar #'(lambda (lg-indexentries) (make-letter-group (sort-indexentries lg-indexentries))) letter-groups) index)))) ;; line 622 "index.nw" (defun build-indexentry-tree-recursive (idxent-list max-depth &optional (curr-depth 1)) (cond ((endp idxent-list) idxent-list) #| nothing more to do |# ((> curr-depth max-depth) #| we reached the end |# (gen-all-sort-keys idxent-list) #| this is the then case |# ) (t (let ((idxent-slist (split-list #'(lambda (idxent) (car (get-merge-key idxent))) idxent-list :headfunc #'(lambda (idxent) (= 1 (length (get-merge-key idxent))))))) (mapcar #'(lambda (sublist) (let* ((idxent (car sublist)) (merge-key (get-merge-key idxent))) (if (= 1 (length merge-key)) (progn #| length = 1 |# (set-sort-key #-:ORDRULES merge-key #+:ORDRULES (gen-keyword-sortkey-list merge-key 0) idxent) (set-subentries (sort-indexentries (build-indexentry-tree-recursive (remove-first-keywords (cdr sublist)) max-depth (1+ curr-depth))) idxent) idxent) (let* #| length > 1 |# ((main-key (get-main-key idxent)) (new-merge-key (take-first merge-key)) (some-print-key (find-print-key sublist)) (new-print-key (list (or some-print-key (car main-key)))) (new-idxent (make-index-entry :main-key (take-first main-key) :merge-key new-merge-key :print-key new-print-key :sort-key #-:ORDRULES new-merge-key #+:ORDRULES (gen-keyword-sortkey-list new-merge-key 0) :idxclass (get-idxclass idxent)))) ;; (info "~&(treeing :main ~S :some-print ~S :new-print ~S)" ;; main-key some-print-key new-print-key) (set-subentries (sort-indexentries (build-indexentry-tree-recursive (remove-first-keywords sublist) max-depth (1+ curr-depth))) new-idxent) new-idxent)))) idxent-slist))))) (defun find-print-key (idxent-list) (some #'(lambda (idxent) (car (get-print-key idxent))) idxent-list)) ;; line 689 "index.nw" (defun remove-first-keywords (idxent-list) (declare (inline)) (mapc #'(lambda (idxent) (setf (slot-value idxent 'merge-key) (cdr (slot-value idxent 'merge-key))) (setf (slot-value idxent 'main-key) (cdr (slot-value idxent 'main-key))) (setf (slot-value idxent 'print-key) (cdr (slot-value idxent 'print-key))) ) idxent-list) idxent-list) ;; line 713 "index.nw" (defun gen-all-sort-keys (idxent-list) (when idxent-list (mapc #'(lambda (idxent) (set-sort-key #-:ORDRULES (get-merge-key idxent) #+:ORDRULES (gen-keyword-sortkey-list (get-merge-key idxent) 0) idxent)) idxent-list)) idxent-list) ;; line 94 "index.nw" (defparameter *index* nil) (defun create-index () (setq *index* (make-base-index *indexstyle*)) (setq *index-entry-table* (get-entry-table *index*)) *index*) (create-index) ;; line 421 "index.nw" (defun lookup-indexentry (key &optional (index-entry-table *index-entry-table*)) (gethash key index-entry-table)) ;; line 258 "index.nw" (eval-when (compile load eval) (defparameter *raw-index-interface-definitions* '(indexentry))) ;; line 165 "index.nw" (defmacro indexentry (&whole whole &rest args) (destructuring-switch-bind (&key key print tkey merge attr locref xref &switch (open-range :open-range) (close-range :close-range)) args (cond ((not (or key tkey)) (error "missing argument :key or :tkey in~%~S.")) ((and key tkey) (error "you can't specify :key and :tkey at the same time in~%~S." whole)) ((and locref xref) ;; line 213 "index.nw" (error "you can't specify :locref and :xref at the same time in~%~S." whole) ;; line 177 "index.nw" ) (t (progn (if tkey (multiple-value-setq (key print) (tkey-to-normal-key tkey whole)) (when print;; check for correct key-length (let ((keylen (length key))) (unless (= keylen (length print)) (setq print;; take the first keylen elmts of print (mapcar #'(lambda (x y) (declare (ignore y)) x) key (append print (make-list keylen)))))))) (cond ((not (listp key)) (error ":key ~S is not a list in~%~S." key whole)) ((not (listp print)) (error ":print ~S is not a list in~%~S." print whole)) (locref `(ADD-LAYERED-LOCREF-INDEXENTRY :MAIN-KEY ',key :PRINT-KEY ',print :MERGE-KEY ',merge :CATATTR ',attr :LOCREF ',locref :OPEN-RANGE ',open-range :CLOSE-RANGE ',close-range)) (xref (when (or open-range close-range) ;; line 221 "index.nw" (error "you can't specify :open-range or :close-range with :xref at the same time in~%~S." whole) ;; line 202 "index.nw" ) (unless attr ;; line 217 "index.nw" (error "missing :attr in combination with :xref in~%~S." whole) ;; line 203 "index.nw" ) `(ADD-CROSSREF-INDEXENTRY :MAIN-KEY ',key :PRINT-KEY ',print :XREF ',xref :XREF-CLASS-NAME ',attr)) (t ;; line 226 "index.nw" (error "you must at least specify :locref or :xref in~%~S." whole) ;; line 209 "index.nw" ))))))) ;; line 238 "index.nw" (defun tkey-to-normal-key (tkey whole) (when (not (listp tkey)) ;; line 254 "index.nw" (error "INDEXENTRY: invalid structure of :tkey in~%~S." tkey whole) ;; line 239 "index.nw" ) (let ((main-key '()) (print-key '())) (mapc #'(lambda (key-elt) (cond ((listp key-elt) (push (car key-elt) main-key) (if (cdr key-elt) (push (cadr key-elt) print-key) (push nil print-key))) (t ;; line 254 "index.nw" (error "INDEXENTRY: invalid structure of :tkey in~%~S." tkey whole) ;; line 248 "index.nw" ))) tkey) (values (nreverse main-key) (nreverse print-key)))) ;; line 889 "index.nw" (eval-when (compile load eval) ;; line 83 "index.nw" (export '(base-index make-base-index get-entries)) ;; line 105 "index.nw" (export '(*index* create-index)) ;; line 264 "index.nw" (export '*raw-index-interface-definitions*) (export *raw-index-interface-definitions*) ;; line 412 "index.nw" (export '(add-locref-indexentry add-crossref-indexentry)) ;; line 530 "index.nw" (export '(process-index)) ;; line 564 "index.nw" (export '(letter-group get-members get-group-definition)) ;; line 891 "index.nw" ) ;; line 1029 "idxentry.nw" #+:XP (set-pprint-dispatch 'index-entry #'(lambda (s idxent) (pprint-logical-block (s nil :suffix "}") (pprint-indent :block 2 s) (write-string "Indexentry {" s) (pprint-newline :mandatory s) (write-string "main-key: " s) (write (get-main-key idxent) :stream s) (pprint-newline :mandatory s) (write-string "merge-key: " s) (write (get-merge-key idxent) :stream s) (pprint-newline :mandatory s) (write-string "sort-key: " s) (write (get-sort-key idxent) :stream s) (pprint-newline :mandatory s) (pprint-logical-block (s nil :suffix "}") (write-string "Locrefs {" s) (pprint-indent :block 2) (pprint-newline :mandatory s) (pprint-linear s (get-locrefs idxent))) (pprint-newline :mandatory s) (pprint-logical-block (s nil :suffix "}") (write-string "Subentries {" s) (pprint-indent :block 2) (pprint-newline :mandatory s) (pprint-linear s (get-subentries idxent))) (pprint-newline :mandatory s)) )) ;; line 1071 "idxentry.nw" #+:XP (defun pprint-locref-group (s grp name) (format s "~%") (pprint-logical-block (s nil :prefix "(" :suffix ")") (write-string name s) (write-string ":" s) (when (typep grp 'category-attribute-group) (write (get-ordnum grp) :stream s)) (pprint-indent :block 2 s) (pprint-newline :mandatory s) (pprint-fill s (get-members grp) nil) (pprint-indent :block -1 s) (pprint-newline :mandatory s))) #+:XP (defun set-pprint-locref-group-dispatch (class name &optional (rank 0)) (set-pprint-dispatch class #'(lambda (s grp) (pprint-locref-group s grp name)) rank)) ;; line 1107 "idxentry.nw" #+:XP (set-pprint-locref-group-dispatch 'locref-group "LOCREF-GROUP" 0) #+:XP (set-pprint-locref-group-dispatch 'locref-class-group "LOCREF-CLASS-GROUP" 1) #+:XP (set-pprint-locref-group-dispatch 'crossref-class-group "CROSSREF-CLASS-GROUP" 2) #+:XP (set-pprint-locref-group-dispatch 'category-attribute-group "CATEGORY-ATTRIBUTE-GROUP" 3) ;; line 614 "ranges.nw" #+:XP (defun pprint-location-range (s range) (pprint-logical-block (s nil :prefix "[" :suffix "]") (format s "range: ~D " (get-length range)) (pprint-newline :fill s) (write-string " loccls: " s) (write (get-locclass range) :stream s) (pprint-newline :fill s) (write-string " catattr: " s) (write (get-catattr range) :stream s) (format s "/~D" (get-sort-ordnum (get-catattr range))) (pprint-newline :fill s) (format s " ordnums: ~A " (get-ordnums range)) (pprint-newline :fill s) (pprint-logical-block (s nil :prefix "<" :suffix ">") (write-string "first " s) (pprint-newline :miser s) (write (get-first range) :stream s)) (pprint-newline :mandatory s) (pprint-logical-block (s nil :prefix "<" :suffix ">") (write-string "inner " s) (pprint-newline :linear s) (write (get-inner range) :stream s)) (pprint-newline :mandatory s) (pprint-logical-block (s nil :prefix "<" :suffix ">") (write-string "last " s) (pprint-newline :miser s) (write (get-last range) :stream s)) (pprint-newline :mandatory s))) #+:XP (set-pprint-dispatch 'location-range #'pprint-location-range) ;; line 868 "index.nw" (defvar *RCS-Identifier* '( ;; line 998 "idxentry.nw" ("idxentry" . "$Id: idxentry.nw,v 1.29 1997/03/27 17:17:25 kehr Exp $") ;; line 895 "index.nw" ("index" . "$Id: index.nw,v 1.31 1997/03/26 16:18:37 kehr Exp $") ;; line 606 "ranges.nw" ("ranges" . "$Id: ranges.nw,v 1.11 1997/03/26 16:18:41 kehr Exp $") ;; line 868 "index.nw" ))