summaryrefslogtreecommitdiff
path: root/Build/source/utils/xindy/xindy-src/src/locref.lsp
diff options
context:
space:
mode:
Diffstat (limited to 'Build/source/utils/xindy/xindy-src/src/locref.lsp')
-rw-r--r--Build/source/utils/xindy/xindy-src/src/locref.lsp556
1 files changed, 0 insertions, 556 deletions
diff --git a/Build/source/utils/xindy/xindy-src/src/locref.lsp b/Build/source/utils/xindy/xindy-src/src/locref.lsp
deleted file mode 100644
index 428b629e910..00000000000
--- a/Build/source/utils/xindy/xindy-src/src/locref.lsp
+++ /dev/null
@@ -1,556 +0,0 @@
-;; line 360 "locref.nw"
-;; $Id: locref.nw,v 1.29 1997/03/26 16:18:53 kehr Exp $
-
-(lisp:defpackage "LOCREF")
-(lisp:in-package "LOCREF")
-(lisp:provide "locref")
-
-#+CLISP (lisp:require "base")
-
-(eval-when (compile load eval)
- #-CLISP (lisp:require "base")
- (lisp:use-package "BASE")
- #+(and :XP CLISP) (lisp:use-package "XP")
- (lisp:use-package "CLOS"))
-
-;; line 251 "basetype.nw"
-;; $Id: basetype.nw,v 1.17 1997/03/26 16:18:47 kehr Exp $
-
-;; line 110 "basetype.nw"
-(defgeneric prefix-match (str object))
-;; line 114 "basetype.nw"
-(defclass basetype ()
- ((name :initarg :name)
- (base-alphabet :initarg :base-alphabet)))
-;; line 142 "basetype.nw"
-(defclass alphabet (basetype)
- ((symbols :initarg :symbols)))
-
-(defun make-alphabet (name symbols)
- (make-instance 'alphabet :name name :symbols symbols
- :base-alphabet (calculate-base-alphabet symbols)))
-
-(defmethod make-copy ((alph alphabet) new-name)
- (make-instance 'alphabet
- :name new-name
- :symbols (get-symbols alph)
- :base-alphabet (get-base-alphabet alph)))
-;; line 163 "basetype.nw"
-(defun calculate-base-alphabet (list-of-strings)
- (sort (remove-duplicates
- (apply #'nconc
- (mapcar #'(lambda (str)
- (coerce str 'list))
- list-of-strings)))
- #'char<))
-;; line 183 "basetype.nw"
-(defmethod prefix-match ((str string) (alph alphabet))
- (multiple-value-bind (matched-string rest-string order-num)
- (prefix-match-stringlist str (get-symbols alph))
- (values matched-string rest-string order-num)))
-
-(defun prefix-match-stringlist (pattern list-of-str)
- (let* ((matched-string "")
- (rest-string pattern)
- (ordnum-of-max-match nil)
- (len-max-match 0)
- (strlen (length pattern)))
- (do ((ordnum 0 (1+ ordnum))
- (string-list list-of-str (cdr string-list)))
- ((endp string-list))
- (let ((len-curr-match (string/= pattern (car string-list))))
- (when (null len-curr-match) (setq len-curr-match strlen))
- (when (> len-curr-match len-max-match)
- (setq ordnum-of-max-match ordnum)
- (setq len-max-match len-curr-match)
- (setq rest-string (subseq pattern len-curr-match))
- (setq matched-string
- (subseq (car string-list) 0 len-curr-match)))))
- (values matched-string rest-string ordnum-of-max-match)))
-;; line 227 "basetype.nw"
-(defclass enumeration (basetype)
- ())
-
-(defun make-enumeration (enum-class name base-alphabet)
- (make-instance enum-class
- :name name
- :base-alphabet base-alphabet))
-
-(defmethod make-copy ((enum enumeration) new-name)
- (make-instance (class-name (class-of enum))
- :name new-name
- :base-alphabet (get-base-alphabet enum)))
-
-;; line 257 "basetype.nw"
-(eval-when (compile load eval)
-
-;; line 120 "basetype.nw"
-(export '(basetype prefix-match get-name get-base-alphabet))
-;; line 157 "basetype.nw"
-(export '(alphabet make-alphabet get-symbols make-copy))
-;; line 242 "basetype.nw"
-(export '(enumeration make-enumeration))
-;; line 259 "basetype.nw"
- )
-;; line 493 "locclass.nw"
-;; $Id: locclass.nw,v 1.21 1997/03/26 16:18:49 kehr Exp $
-
-;; line 67 "locclass.nw"
-(defclass location-class ()
- ((name :type string :initarg :name)
- (ordnum :type number :initform (gen-next-loccls-ordnum))))
-;; line 87 "locclass.nw"
-(defparameter *curr-loccls-ordnum* 0)
-
-(defun gen-next-loccls-ordnum ()
- (incf *curr-loccls-ordnum*))
-;; line 106 "locclass.nw"
-(defclass layered-location-class (location-class)
- ((layers :initarg :layers)
- (hierdepth :initarg :hierdepth)))
-;; line 125 "locclass.nw"
-(defclass standard-location-class (layered-location-class)
- ((join-length :initarg :join-length)))
-
-(defun make-standard-location-class (name layers join-length hierdepth)
- (make-instance 'standard-location-class
- :name name :layers layers
- :join-length join-length :hierdepth hierdepth))
-;; line 135 "locclass.nw"
-(defmacro joining-allowed-p (loccls)
- `(SLOT-VALUE ,loccls 'JOIN-LENGTH))
-;; line 144 "locclass.nw"
-(defun checked-make-standard-location-class (name layers join-layers
- &optional (hierdepth 0))
- (make-standard-location-class name layers join-layers hierdepth))
-;; line 163 "locclass.nw"
-(defclass var-location-class (layered-location-class)
- ())
-
-(defun make-var-location-class (name layers hierdepth)
- (make-instance 'var-location-class
- :name name :layers layers :hierdepth hierdepth))
-;; line 172 "locclass.nw"
-(defun checked-make-var-location-class (name layers &optional (hierdepth 0))
- (make-var-location-class name layers hierdepth))
-;; line 189 "locclass.nw"
-(defclass loccls-layer ()
- ((basetype :initarg :basetype)))
-
-(defun make-loccls-layer (basetype)
- (make-instance 'loccls-layer :basetype basetype))
-;; line 206 "locclass.nw"
-(defmethod prefix-match ((locstring string)
- (layer loccls-layer))
- (prefix-match locstring (get-basetype layer)))
-;; line 220 "locclass.nw"
-(defclass loccls-separator ()
- ((separator :initarg :separator)))
-
-(defun make-loccls-separator (separator)
- (make-instance 'loccls-separator :separator separator))
-;; line 246 "locclass.nw"
-(defmethod prefix-match ((locstring string)
- (separator loccls-separator))
- (let* ((sepstr (get-separator separator))
- (seplen (length sepstr))
- (match-len (string/= sepstr locstring)))
- (if (or (null match-len) (eql seplen match-len))
- (values locstring (subseq locstring seplen) t)
- (values nil nil nil))))
-;; line 273 "locclass.nw"
-(defclass crossref-location-class (location-class)
- ((target :initarg :target)))
-;; line 299 "locclass.nw"
-(defclass verified-crossref-location-class (crossref-location-class)
- ())
-
-(defun make-verified-crossref-location-class (name)
- (make-instance 'verified-crossref-location-class :name name))
-;; line 319 "locclass.nw"
-(defclass unverified-crossref-location-class (crossref-location-class)
- ())
-
-(defun make-unverified-crossref-location-class (name)
- (make-instance 'unverified-crossref-location-class :name name))
-
-;; line 374 "locclass.nw"
-(defgeneric perform-match (locstring locclass))
-;; line 402 "locclass.nw"
-(defmethod perform-match ((locstring string)
- (loccls standard-location-class))
- (let ((layer-list '())
- (ordnum-list '())
- (give-up nil)
- (matched-string nil)
- (rest-string nil)
- (ordnum nil))
- (do ((layers (get-layers loccls) (cdr layers)))
- ((or give-up
- (let ((empty-string (= 0 (length locstring)))
- (empty-list (endp layers)))
- (cond ((and empty-string empty-list) t)
- ((or empty-string empty-list) (setq give-up t))
- (t nil)))))
- (let ((curr-layer (car layers)))
- (multiple-value-setq (matched-string rest-string ordnum)
- (prefix-match locstring curr-layer))
- (cond ((eq ordnum nil) (setq give-up t))
- ((numberp ordnum)
- (setq locstring rest-string)
- (setq layer-list
- (cons matched-string layer-list))
- (setq ordnum-list (cons ordnum ordnum-list)))
- (t (setq locstring rest-string)))
- ))
- (if (not give-up)
- (values (nreverse layer-list) (nreverse ordnum-list))
- (values nil nil))))
-;; line 446 "locclass.nw"
-(defmethod perform-match ((locstring string)
- (loccls var-location-class))
- (let ((layer-list '())
- (ordnum-list '())
- (give-up nil)
- (matched-string nil)
- (rest-string nil)
- (ordnum nil))
- (do ((layers (get-layers loccls) (cdr layers)))
- ((or give-up
- (let ((empty-string (= 0 (length locstring)))
- (empty-list (endp layers)))
- (cond (empty-string t)
- (empty-list (setq give-up t))
- (t nil)))))
- (let ((curr-layer (car layers)))
- (multiple-value-setq (matched-string rest-string ordnum)
- (prefix-match locstring curr-layer))
- (cond ((eq ordnum nil) (setq give-up t))
- ((numberp ordnum)
- (setq locstring rest-string)
- (setq layer-list
- (cons matched-string layer-list))
- (setq ordnum-list (cons ordnum ordnum-list)))
- (t (setq locstring rest-string)))
- ))
- (if (not give-up)
- (values (nreverse layer-list) (nreverse ordnum-list))
- (values nil nil))))
-;; line 482 "locclass.nw"
-;; FIXME (do we need this)
-;;(defmethod perform-match ((locstring string)
-;; (loccls crossref-location-class))
-;; t)
-
-;; line 507 "locclass.nw"
-(eval-when (compile load eval)
-
-;; line 94 "locclass.nw"
-(export '(location-class perform-match
- get-name get-ordnum set-ordnum ordnum))
-;; line 112 "locclass.nw"
-(export '(layered-location-class))
-;; line 150 "locclass.nw"
-(export '(standard-location-class checked-make-standard-location-class
- get-join-length set-join-length
- joining-allowed-p join-length))
-;; line 177 "locclass.nw"
-(export '(var-location-class checked-make-var-location-class))
-;; line 197 "locclass.nw"
-(export '(loccls-layer make-loccls-layer
- get-basetype get-markup))
-;; line 228 "locclass.nw"
-(export '(loccls-separator make-loccls-separator
- get-separator get-markup))
-;; line 278 "locclass.nw"
-(export '(crossref-location-class get-target))
-;; line 307 "locclass.nw"
-(export '(verified-crossref-location-class
- make-verified-crossref-location-class))
-;; line 327 "locclass.nw"
-(export '(unverified-crossref-location-class
- make-unverified-crossref-location-class))
-;; line 183 "locref.nw"
-(export '(crossref-location-reference create-cross-reference))
-;; line 215 "locref.nw"
-(export 'build-location-reference)
-;; line 509 "locclass.nw"
- )
-;; line 56 "locref.nw"
-(defclass location-reference ()
- ((locclass :initarg :locclass)
- (attribute :initarg :attribute)))
-;; line 78 "locref.nw"
-(defclass layered-location-reference (location-reference)
- ((layers :initarg :layers)
- (locref-string :initarg :string :type string)
- (ordnums :initarg :ordnums)
- (catattr :initarg :catattr)
- (state :initarg :state)
- (rangeattr :initform 'nil)
- (origin :initform 'nil)
- (subrefs :initform '() :type list)))
-
-;; line 95 "locref.nw"
-(defun make-layered-location-reference (&key (string "")
- (layers '()) (ordnums '())
- (catattr nil) (locclass nil)
- (attribute nil) (virtual nil))
- (make-instance 'layered-location-reference
- :string string
- :layers layers
- :ordnums ordnums
- :catattr catattr
- :locclass locclass
- :attribute attribute
- :state (if virtual 'locref-state-virtual
- 'locref-state-normal)))
-;; line 116 "locref.nw"
-(defmacro state-normal-p (locref)
- `(EQL 'LOCREF-STATE-NORMAL (SLOT-VALUE ,locref 'STATE)))
-
-(defmacro state-virtual-p (locref)
- `(EQL 'LOCREF-STATE-VIRTUAL (SLOT-VALUE ,locref 'STATE)))
-
-(defmacro state-deleted-p (locref)
- `(EQL 'LOCREF-STATE-DELETED (SLOT-VALUE ,locref 'STATE)))
-
-(defun set-state-normal (locref)
- (set-state 'locref-state-normal locref)
- locref)
-
-(defun set-state-virtual (locref)
- (set-state 'locref-state-virtual locref)
- locref)
-
-(defun set-state-deleted (locref)
- (set-state 'locref-state-deleted locref)
- locref)
-;; line 139 "locref.nw"
-(defmacro rangeattr-open-p (attr)
- `(EQL ,attr :RANGEATTR-OPEN))
-
-(defmacro rangeattr-close-p (attr)
- `(EQL ,attr :RANGEATTR-CLOSE))
-
-(defmacro set-rangeattr-open (locref)
- `(SETF (SLOT-VALUE ,locref 'RANGEATTR) :RANGEATTR-OPEN))
-
-(defmacro set-rangeattr-close (locref)
- `(SETF (SLOT-VALUE ,locref 'RANGEATTR) :RANGEATTR-CLOSE))
-;; line 241 "locref.nw"
-(defclass category-attribute ()
- ((name :initarg :name)
- (catattr-grp-ordnum :initarg :ordnum)
- (sort-ordnum :initform 0)
- (processing-ordnum :initform 0)
- (last-in-group :initarg :type)))
-
-(defun make-category-attribute (attr-name)
- (make-instance 'category-attribute :name attr-name))
-;; line 174 "locref.nw"
-(defclass crossref-location-reference (location-reference)
- ((target :initarg :target)))
-
-(defun create-cross-reference (loccls target attribute)
- (make-instance 'crossref-location-reference
- :locclass loccls :target target :attribute attribute))
-;; line 201 "locref.nw"
-(defmethod build-location-reference ((locclass layered-location-class)
- (locref-str string)
- (catattr category-attribute)
- attribute)
- (multiple-value-bind (layers ordnums)
- (perform-match locref-str locclass)
- (and layers ordnums
- (make-layered-location-reference
- :locclass locclass :layers layers
- :ordnums ordnums :catattr catattr
- :attribute attribute :string locref-str))))
-;; line 288 "locref.nw"
-(defun locref-class< (locref-1 locref-2)
- (declare (inline))
- (< (get-ordnum (get-locclass locref-1))
- (get-ordnum (get-locclass locref-2))))
-
-(defun locref-class= (locref-1 locref-2)
- (declare (inline))
- (eql (get-locclass locref-1) (get-locclass locref-2)))
-;; line 301 "locref.nw"
-(defmacro locref-ordnum< (ordnum-list-1 ordnum-list-2)
- `(COND
- ((EQUAL ,ordnum-list-1 ,ordnum-list-2) NIL)
- (T (DO ((REST-1 ,ordnum-list-1 (CDR REST-1))
- (REST-2 ,ordnum-list-2 (CDR REST-2)))
- ((OR (ENDP REST-1) (ENDP REST-2)
- (/= (FIRST REST-1) (FIRST REST-2)))
- (COND ((ENDP REST-1) T)
- ((ENDP REST-2) NIL)
- (T (< (FIRST REST-1) (FIRST REST-2)))))))))
-
-(defmacro locref-ordnum= (ordnum-list-1 ordnum-list-2)
- `(EQUAL ,ordnum-list-1 ,ordnum-list-2))
-;; line 320 "locref.nw"
-#|
-FIXME
-(defun locref< (locref-1 locref-2)
- (cond ((locref-class= locref-1 locref-2)
- (locref-ordnum< locref-1 locref-2))
- (t (locref-class< locref-1 locref-2))))
-|#
-
-(defmethod locref= ((locref-1 crossref-location-reference)
- (locref-2 layered-location-reference))
- nil)
-
-(defmethod locref= ((locref-1 layered-location-reference)
- (locref-2 crossref-location-reference))
- nil)
-
-(defmethod locref= ((locref-1 crossref-location-reference)
- (locref-2 crossref-location-reference))
- (and (locref-class= locref-1 locref-2)
- (equal (get-target locref-1) (get-target locref-2))))
-
-(defmethod locref= ((locref-1 layered-location-reference)
- (locref-2 layered-location-reference))
- (and (locref-class= locref-1 locref-2)
- (eql (get-catattr locref-1) (get-catattr locref-2))
- (locref-ordnum= (get-ordnums locref-1) (get-ordnums locref-2))
- (eql (get-rangeattr locref-1) (get-rangeattr locref-2))))
-
-;; line 391 "locref.nw"
-(eval-when (compile load eval)
-
-;; line 62 "locref.nw"
-(export 'location-reference)
-;; line 153 "locref.nw"
-(export '(layered-location-reference
- make-layered-location-reference
- get-layers set-layers layers
- get-ordnums set-ordnums ordnums
- get-subrefs set-subrefs subrefs
- get-catattr catattr
- get-rangeattr rangeattr
- get-locref-string string
- get-origin set-origin
- state
- state-normal-p state-virtual-p state-deleted-p
- set-state-normal set-state-virtual set-state-deleted
- set-rangeattr-open set-rangeattr-close
- rangeattr-open-p rangeattr-close-p))
-;; line 257 "locref.nw"
-(export '(category-attribute make-category-attribute
- get-name catattr-grp-ordnum
- get-catattr-grp-ordnum set-catattr-grp-ordnum
- get-sort-ordnum set-sort-ordnum
- get-processing-ordnum set-processing-ordnum
- get-last-in-group set-last-in-group
- get-type set-type
- get-markup set-markup))
-;; line 350 "locref.nw"
-(export '(locref-class< locref-class=
- locref-ordnum< locref-ordnum=
- locref=))
-;; line 393 "locref.nw"
- )
-
-;; line 521 "locclass.nw"
-#+:XP
-(set-pprint-dispatch 'location-class
- #'(lambda (s loccls)
- (pprint-logical-block
- (s nil :prefix "{" :suffix "}")
- (write (get-name loccls) :stream s)
- (write-string ":" s)
- (write (get-ordnum loccls) :stream s))))
-
-#+:XP
-(set-pprint-dispatch 'layered-location-class
- #'(lambda (s loccls)
- (pprint-logical-block
- (s nil :prefix "{" :suffix "}")
- (write (get-name loccls) :stream s)
- (write-string ":" s)
- (write (get-ordnum loccls) :stream s)
- (mapc #'(lambda (x)
- (write-string " " s)
- (pprint x s))
- (get-layers loccls)))))
-
-#+:XP
-(set-pprint-dispatch 'loccls-layer
- #'(lambda (s layer)
- (pprint-logical-block
- (s nil :prefix "<" :suffix ">")
- (pprint (get-basetype layer) s))))
-
-#+:XP
-(set-pprint-dispatch 'loccls-separator
- #'(lambda (s sep)
- (pprint-logical-block
- (s nil :prefix "<" :suffix ">")
- (write (get-separator sep) :stream s))))
-;; line 406 "locref.nw"
-#+:XP
-(defun pprint-layered-location-reference (s locref)
- (pprint-logical-block
- (s nil :prefix "[" :suffix "]")
- (cond ((state-normal-p locref) (write-string "Nor:" s))
- ((state-virtual-p locref) (write-string "Vir:" s))
- (t (write-string "Del:" s)))
- (cond ((rangeattr-open-p (get-rangeattr locref)) (write-string "OPEN:" s))
- ((rangeattr-close-p (get-rangeattr locref)) (write-string "CLOSE:" s)))
- (write-string "\"" s)
- (write-string (get-locref-string locref) s)
- (write-string "\"=" s)
- (write (get-layers locref) :stream s)
- (write-string "=" s)
- (write (get-ordnums locref) :stream s)
- (write-string ";" s)
- (pprint-newline :fill s)
- (write (get-locclass locref) :stream s)
- (write-string ";" s)
- (pprint-newline :fill s)
- (write (get-catattr locref) :stream s)
- (when (get-origin locref)
- (write-string "<-" s)
- (write (get-catattr (get-origin locref)) :stream s))
- (pprint-newline :fill s)
- (write (get-subrefs locref) :stream s)
- ))
-
-#+:XP
-(set-pprint-dispatch 'layered-location-reference
- #'pprint-layered-location-reference)
-;; line 440 "locref.nw"
-#+:XP
-(defun pprint-crossref-location-reference (s xref)
- (pprint-logical-block
- (s nil :prefix "[" :suffix "]")
- (write (get-locclass xref) :stream s)
- (write-string "->" s)
- (write (get-target xref) :stream s)
- ))
-
-#+:XP
-(set-pprint-dispatch 'crossref-location-reference
- #'pprint-crossref-location-reference)
-;; line 455 "locref.nw"
-#+:XP
-(set-pprint-dispatch 'category-attribute
- #'(lambda (s catattr)
- (write-string "`" s)
- (write-string (get-name catattr) s)
- (write-string "'" s)))
-
-;; line 380 "locref.nw"
-(defvar *RCS-Identifier* '(
-;; line 263 "basetype.nw"
-("basetype" . "$Id: basetype.nw,v 1.17 1997/03/26 16:18:47 kehr Exp $")
-;; line 513 "locclass.nw"
-("locclass" . "$Id: locclass.nw,v 1.21 1997/03/26 16:18:49 kehr Exp $")
-;; line 397 "locref.nw"
-("locref" . "$Id: locref.nw,v 1.29 1997/03/26 16:18:53 kehr Exp $")
-;; line 380 "locref.nw"
- ))