diff options
Diffstat (limited to 'Build/source/utils/xindy/xindy-src/src/ordrules.lsp')
-rw-r--r-- | Build/source/utils/xindy/xindy-src/src/ordrules.lsp | 419 |
1 files changed, 0 insertions, 419 deletions
diff --git a/Build/source/utils/xindy/xindy-src/src/ordrules.lsp b/Build/source/utils/xindy/xindy-src/src/ordrules.lsp deleted file mode 100644 index ea372eb94ea..00000000000 --- a/Build/source/utils/xindy/xindy-src/src/ordrules.lsp +++ /dev/null @@ -1,419 +0,0 @@ -;;; $Id$ -;;;---------------------------------------------------------------------- - -;;; -;;; ordrules --- order rules for xindy -;;; -;;; (history at end) - - -(provide "ordrules") - - -;;;; ============================================================ -;;;; -;;;; SPECIFICATION -;;;; - -;;; -;;; package ordrules XXX -;;; - -(defpackage "ORDRULES" - (:documentation "Order rules for xindy. -Provides functionality for merge-rules and sort-rules, as ordrule collections. -An ordrule collection is an ordered set of order rules. -An order rule is an object that manages replacement of a string or -regular expression by a string. -Ordrule collections are applied to strings, the result is created by -successive application of matching order rules.") - (:use common-lisp clos regexp) - (:shadow match) - (:export ;; object interface - "MAKE-ORDRULE-TABLE" "ADD-RULE" "APPLY-RULES" - ;; legacy (C plugin) interface - "INITIALIZE" "ADD-KEYWORD-MERGE-RULE" "ADD-KEYWORD-SORT-RULE" - "GEN-KEYWORD-MERGEKEY" "GEN-KEYWORD-SORTKEY" - "*MESSAGE-BUFFER-PTR*" "*MESSAGE-BUFFER*" "*MESSAGE-LOGGING*") - ) -(in-package "ORDRULES") - - - -;;;; ============================================================ -;;;; -;;;; ORDRULE OBJECTS -;;;; - -;;; class ORDRULE -;;; Slots: -;;; -- match: regexp, string, or char that might be matched -;;; -- repl: replacement for the matched substring -;;; -- again: boolean flag if repl should be eligible for further ordrules -;;; -;;; subclass ORDRULE-STRING -- no additional slots -;;; subclass ORDRULE-CHAR -- no additional slots -;;; subclass ORDRULE-REGEXP -;;; Additional Slots: -;;; -- only-at-start: boolean flag if match should only be tested at start -;;; of string - -(defclass ordrule () - ((match :initarg :match :reader match) - (repl :initarg :repl :reader repl) - (again :initarg :again :reader again)) - (:documentation - "An order rule that represents the replacement of a matching expression -with a replacement string.")) - -(defclass ordrule-string (ordrule) - () - (:documentation - "An ordrule where the matching expression is a string")) - -(defclass ordrule-char (ordrule) - () - (:documentation - "An ordrule where the matching expression is a char")) - -(defclass ordrule-regexp (ordrule) - ((pattern :initarg :pattern :reader pattern) - (only-at-start :initarg :only-at-start :reader only-at-start)) - (:documentation - "An ordrule where the matching expression is a regexp")) - -(defmethod print-object ((obj ordrule) stream) - "Print an ordrule." - (format stream "#<ordrule: '~A' => '~A' :again ~A>" - (match obj) (repl obj) (again obj))) - -(defmethod print-object ((obj ordrule-regexp) stream) - "Print an ordrule." - (format stream "#<ordrule-regexp: '~A' => '~A' :again ~A :only-at-start ~A>" - (pattern obj) (repl obj) (again obj) (only-at-start obj))) - -(defun make-ordrule-string (match repl &key again) - "Create an ordrule-string object. -MATCH is a string to compare." - (make-instance 'ordrule-string :match match :repl repl :again again)) - -(defun make-ordrule-char (match repl &key again) - "Create an ordrule-string object. -MATCH is a character to compare." - (make-instance 'ordrule-char :match match :repl (string repl) :again again)) - -(defun make-ordrule-regexp (match-pattern repl &key again (extended t)) - "Create an ordrule-regexp object. -MATCH-PATTERN is a POSIX regular expression. -The boolean keyword argument :extended tells if the regex is a basic -one or an extended one; default is to use extended ones." - (let* ((only-at-start (char= (char match-pattern 0) #\^)) - (match (if only-at-start (subseq match-pattern 1) match-pattern))) - (make-instance 'ordrule-regexp - :match (regexp-compile (concatenate 'string "^(" match ")") - :extended extended) - :repl repl :again again - :pattern match-pattern :only-at-start only-at-start))) - -;; A regexp-compile object does not survive dump and reload. -;; Therefore we have to initialize it at first usage. -(defvar *REGEXP-PATTERN* - nil - "If this pattern matches, the string is a regexp.") - -(defun make-ordrule (match repl &key again) - "Create an ordrule object. -MATCH may be a string, a char, or a POSIX regular expression. -If it's a regexp, it's an extended one." - (or *REGEXP-PATTERN* - (setq *REGEXP-PATTERN* (regexp-compile "[][|(){}.*+^$?]"))) - (cond ((characterp match) - (make-ordrule-char match repl :again again)) - ((= (length match) 1) - (make-ordrule-char (char match 0) repl :again again)) - ((regexp-exec *REGEXP-PATTERN* match) - (make-ordrule-regexp match repl :again again)) - (t (make-ordrule-string match repl :again again)))) - - -;;; -;;; (try-rule RULE SOURCE) => FINAL ; SOURCE-REST or <no values> -;;; - -(defgeneric try-rule (ordrule source &key at-start) - (:documentation "Apply an ordrule to a source string. -If the rule does not match, return nothing. If it matches, return two -values: the 1st is the final prefix with the replacement -string and the 2nd is the rest of SOURCE that's left after the matched -text. If the rule's again flag is true, FINAL will be the empty string -and the replacement will be at the start of SOURCE-REST. -An ordrule is not allowed to turn a source completely into an empty string. -If that would happen, a warning is output and nothing is returned. -That situation would exist, if AT-START is true and both FINAL and -SOURCE-REST would be empty. -AT-START tells if we are at the start to process the source string.")) - -(defmethod try-rule ((rule ordrule-char) source &key at-start) - (if (char= (char source 0) (match rule)) - (maybe-again-maybe-no rule source at-start - (repl rule) (subseq source 1)) - (values))) - -(defun maybe-again-maybe-no (rule source at-start repl source-rest) - (cond ((and at-start (string= repl "") (string= source-rest "")) - (warn "Would replace complete index key by empty string, ignoring ~S" rule) - (values source "")) - ((again rule) - (values "" (concatenate 'string repl source-rest))) - (t (values repl source-rest)))) - -(defmethod try-rule ((rule ordrule-string) source &key at-start) - (let* ((match-string (match rule)) - (match-length (length match-string))) - (cond ((> match-length (length source)) (values)) - ((string= source match-string :end1 match-length) - (maybe-again-maybe-no rule source at-start - (repl rule) (subseq source match-length))) - (t (values))))) - -(defmethod try-rule ((rule ordrule-regexp) source &key at-start) - (if (and (only-at-start rule) (not at-start)) - nil - (let ((match-regexp (multiple-value-list (regexp-exec (match rule) source)))) - (if match-regexp - (maybe-again-maybe-no rule source at-start - (maybe-repl-subexpr (repl rule) (rest match-regexp) source) - (subseq source (match-end (first match-regexp)))) - (values))))) - -;; A regexp-compile object does not survive dump and reload. -;; Therefore we have to initialize it at first usage. -(defvar *REPL-PATTERN* - nil - "Compiled regexp that matches a backpattern in a regexp replacement text.") - -;; We need to substitute all \x and & constructs in the replacement text by -;; the respective subexpression from source's matches. They are -;; located with a regexp in a loop and we collect in 'final-repl the -;; strings in front of each \x and the actual subexpression. -(defun maybe-repl-subexpr (repl source-matches source) - (or *REPL-PATTERN* - (setq *REPL-PATTERN* (regexp-compile "\\\\([1-9])|&" :extended t))) - (do* ((start 0 (match-end (first subexpr-match))) - (subexpr-match (multiple-value-list (regexp-exec *REPL-PATTERN* repl)) - (multiple-value-list (regexp-exec *REPL-PATTERN* repl - :start start))) - (final-repl "")) - ((null subexpr-match) - ;; Don't forget to return the rest of the string, too. Its - ;; index is now in 'start. - (concatenate 'string final-repl (subseq repl start))) - ;; OK, need a subexpr replacement. First, we determine which subexpression - ;; this shall be: If it's "&", the second match subexpression will be nil, - ;; as the parenthesis did not match anything. Otherwise the 2nd match - ;; subexpr will be the digit. Then we get that subexpression from the - ;; source string. Finally, we add the 'repl string part in front of \x and - ;; the respective subexpression to 'final-repl and are ready to look for - ;; our next \x construct. - (let* ((subexpr-match-struct (second subexpr-match)) - (subexpr (and subexpr-match-struct - (match-string repl subexpr-match-struct))) - (subexpr-repl (match-string source - (nth (if (null subexpr) - 0 - (read-from-string subexpr)) - source-matches)))) - (setq final-repl - (concatenate 'string final-repl - (subseq repl 0 (match-start (first subexpr-match))) - subexpr-repl))))) - - -;;; -;;; (rule-first-char RULE) => char or :regexp -;;; - -(defgeneric rule-first-char (rule) - (:documentation "Returns the first char of a rule match. -This returns either the first char of a rule match, or :regexp -if that first char is a regular expression. The is used to find the -slot for a rule in a rule table.")) - -(defmethod rule-first-char ((rule ordrule-char)) - (match rule)) - -(defmethod rule-first-char ((rule ordrule-string)) - (char (match rule) 0)) - -(defmethod rule-first-char ((rule ordrule-regexp)) - (let* ((pattern (pattern rule)) - (start-index (if (only-at-start rule) 1 0)) - (first-char (char pattern start-index))) - (cond ((char= first-char #\\) - (char pattern (1+ start-index))) - ((find first-char "[]|(){}.*+?") - :regexp) - (t first-char)))) - - - -;;;; ============================================================ -;;;; -;;;; ORDRULE TABLES -;;;; - -;; An ordrule table is a hash table of ordrule lists, indexed by the first -;; character of the rule. The key :regexp is the entry for rules that start -;; with a regexp pattern. - -(defclass ordrule-table () - ((table :initarg :table :reader table)) - (:documentation - "A collection of ordrules.")) - -(defmethod print-object ((obj ordrule-table) stream) - "Print an ordrule table." - (format stream "#<ordrule table with ~A entries>" (hash-table-count (table obj)))) - -(defun make-ordrule-table () - "Create an ordrule-table object." - (make-instance 'ordrule-table :table (make-hash-table :size 256))) - -(defun add-rule (rule-table rule) - "Add a rule to an ordrule table." - (let* ((first-char (rule-first-char rule)) - (first-char-rules (gethash first-char (table rule-table)))) - (if first-char-rules - (nconc first-char-rules (list rule)) - (setf (gethash first-char (table rule-table)) (list rule))))) - -;; XXX This is the place where we might want to sort rules according to their -;; length. But then we should also cache that sort result, because this -;; function is called for each character in the index! -;; -;; XXX Maybe we should try a cache anyhow, to save appends, too? Need to -;; measure that. -(defun get-rules (rule-table source-start) - (append (gethash source-start (table rule-table)) - (gethash :regexp (table rule-table)))) - -(defun apply-rules-once (rule-table source at-start) - "Apply rules from rule-table once to source. -Returns two values: (1) prefix that has been processed, (2) suffix that has -still to be processed." - (dolist (rule (get-rules rule-table (char source 0)) - (values)) - (multiple-value-bind (prefix suffix) - (try-rule rule source :at-start at-start) - (if (stringp prefix) - (return (values prefix suffix)))))) - -(defun apply-rules (rule-table source &optional (at-start t)) - "Apply rules from rule-table to source." - (multiple-value-bind (prefix suffix) - (apply-rules-once rule-table source at-start) - (log-rule (format nil "apply rules once: '~A' => '~A' '~A'~%" - source prefix suffix)) - (cond ((null prefix) - (if (= (length source) 1) - source - (concatenate 'string (subseq source 0 1) - (apply-rules rule-table (subseq source 1) nil)))) - ((string= suffix "") prefix) - (t (concatenate 'string prefix - (apply-rules rule-table suffix nil)))))) - - - -;;;; ============================================================ -;;;; -;;;; LEGACY (C PLUGIN) INTERFACE -;;;; - -;; The following code realizes the interface of xindy 2.3, even though we -;; could now use real Lisp objects. This is a transient phase only. - -(defvar *merge-rule-table* - (make-ordrule-table)) - -;; By default, we have runs 0..7. -(defvar *sort-rule-tables* - (let ((tables (make-array '(8) :element-type 'ordrule-table))) - (dotimes (i 8) - (setf (aref tables i) (make-ordrule-table))) - tables)) - -(defun initialize (num) - (setq *sort-rule-tables* (make-array (list num) :element-type 'ordrule-table)) - (dotimes (i num) - (setf (aref *sort-rule-tables* i) (make-ordrule-table)))) - -(defun add-keyword-rule (rule-table rule repl again ruletype) - (let* ((again (if (= again 1) t nil)) - (rule-obj (ecase ruletype - (0 (make-ordrule rule repl :again again)) - (1 (make-ordrule-string rule repl :again again)) - (2 (make-ordrule-regexp rule repl :again again :extended nil)) - (3 (make-ordrule-regexp rule repl :again again)) - (4 (make-ordrule-char rule repl :again again))))) - (add-rule rule-table rule-obj))) - -(defun add-keyword-merge-rule (rule repl again ruletype) - (let* ((rule-list (add-keyword-rule *merge-rule-table* rule - repl again ruletype)) - (message (format nil "Add merge rule: ~S~%" (first (last rule-list))))) - (log-rule message))) - -(defun add-keyword-sort-rule (run rule repl again ruletype) - (let* ((rule-list (add-keyword-rule (aref *sort-rule-tables* run) - rule repl again ruletype)) - (message (format nil "Add sort rule to run ~A: ~S~%" - run (first (last rule-list))))) - (log-rule message))) - -(defun gen-keyword-mergekey (key) - (let ((result (apply-rules *merge-rule-table* key))) - (log-rule (format nil "Final merge-rule result: '~A' -> '~A'~%" - key result)) - result)) - -(defun gen-keyword-sortkey (key run) - (let ((result (apply-rules (aref *sort-rule-tables* run) key))) - (log-rule (format nil "Final sort-rule result, run ~A: '~A' -> '~A'~%" - run key result)) - result)) - - -;;; -;;; Logging -;;; - -(defvar *message-logging* - nil - "Boolean: Shall rule replacement be logged?") - -(defvar *message-buffer* - "" - "String with the log message. -This is remaining cruft from the C plugin that could not use Lisp -output streams itself.") - -(defvar *message-buffer-ptr* - 0 - "Current position in *message-buffer*. -This is remaining cruft from the C plugin that could not use Lisp -output streams itself.") - -(defun log-rule (message) - (and *message-logging* - (if (= (incf *message-buffer-ptr*) 1) - (setq *message-buffer* message) - (setq *message-buffer* (concatenate 'string *message-buffer* - message))) - )) - - - -;;;====================================================================== -;; -;; $Log$ |