summaryrefslogtreecommitdiff
path: root/Build/source/utils/xindy/xindy-src/src/locref.lsp
blob: 428b629e9107584e083e50f8d7ddd66ef4cdb004 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
;; 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"
                                               ))