path: root/Build/source/utils/xindy/src/locref.lsp

;; 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"
                                               ))