/[cmucl]/src/hemlock/table.lisp
ViewVC logotype

Contents of /src/hemlock/table.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.3 - (show annotations) (vendor branch)
Tue Apr 23 11:53:53 1991 UTC (23 years ago) by ram
Changes since 1.1.1.2: +2 -2 lines
Reduced INITIAL-WORD-TABLE-SIZE from 10 to 2.  The average utilization of this
vector was quite low, and there are 1600 of them in the core.
1 ;;; -*- Log: hemlock.log; Package: HEMLOCK-INTERNALS -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/table.lisp,v 1.1.1.3 1991/04/23 11:53:53 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Reluctantly written by Christopher Hoover
15 ;;; Supporting cast includes Rob and Bill.
16 ;;;
17 ;;; This file defines a data structure, analogous to a Common Lisp
18 ;;; hashtable, which translates strings to values and facilitates
19 ;;; recognition and completion of these strings.
20 ;;;
21
22 (in-package "HEMLOCK-INTERNALS")
23
24 (export '(string-table string-table-p make-string-table
25 string-table-separator getstring
26 find-ambiguous complete-string find-containing
27 delete-string clrstring do-strings))
28
29
30 ;;;; Implementation Details
31
32 ;;; String tables are a data structure somewhat analogous to Common Lisp
33 ;;; hashtables. String tables are case-insensitive. Functions are
34 ;;; provided to quickly look up strings, insert strings, disambiguate or
35 ;;; complete strings, and to provide a variety of ``help'' when
36 ;;; disambiguating or completing strings.
37 ;;;
38 ;;; String tables are represented as a series of word tables which form
39 ;;; a tree. Four structures are used to implement this data structure.
40 ;;; The first is a STRING-TABLE. This structure has severals slots one
41 ;;; of which, FIRST-WORD-TABLE, points to the first word table. This
42 ;;; first word table is also the root of tree. The STRING-TABLE
43 ;;; structure also contains slots to keep track of the number of nodes,
44 ;;; the string table separator (which is used to distinguish word or
45 ;;; field boundaries), and a pointer to an array of VALUE-NODE's.
46 ;;;
47 ;;; A WORD-TABLE is simply an array of pointers to WORD-ENTRY's. This
48 ;;; array is kept sorted by the FOLDED slot in each WORD-ENTRY so that a
49 ;;; binary search can be used. Each WORD-ENTRY contains a case-folded
50 ;;; string and a pointer to the next WORD-TABLE in the tree. By
51 ;;; traversing the tree made up by these structures, searching and
52 ;;; completion can easily be done.
53 ;;;
54 ;;; Another structure, a VALUE-NODE, is used to hold each entry in the
55 ;;; string table and contains both a copy of the original string and a
56 ;;; case-folded version of the original string along with the value.
57 ;;; All of these value nodes are stored in a array (pointed at by the
58 ;;; VALUE-NODES slot of the STRING-TABLE structure) and sorted by the
59 ;;; FOLDED slot in the VALUE-NODE structure so that a binary search may
60 ;;; be used to quickly find existing strings.
61 ;;;
62
63
64 ;;;; Structure Definitions
65
66 (defparameter initial-string-table-size 20
67 "Initial size of string table array for value nodes.")
68 (defparameter initial-word-table-size 2
69 "Inital size of each word table array for each tree node.")
70
71 (defstruct (string-table
72 (:constructor %make-string-table (separator))
73 (:print-function print-string-table))
74 "This structure is used to implement the Hemlock string-table type."
75 ;; Character used to
76 (separator #\Space :type base-character) ; character used for word separator
77 (num-nodes 0 :type fixnum) ; number of nodes in string table
78 (value-nodes (make-array initial-string-table-size)) ; value node array
79 (first-word-table (make-word-table))) ; pointer to first WORD-TABLE
80
81 (defun print-string-table (table stream depth)
82 (declare (ignore table depth))
83 (format stream "#<String Table>"))
84
85 (defun make-string-table (&key (separator #\Space) initial-contents)
86 "Creates and returns a Hemlock string-table. If Intitial-Contents is
87 supplied in the form of an A-list of string-value pairs, these pairs
88 will be used to initialize the table. If Separator, which must be a
89 base-character, is specified then it will be used to distinguish word
90 boundaries."
91 (let ((table (%make-string-table separator)))
92 (dolist (x initial-contents)
93 (setf (getstring (car x) table) (cdr x)))
94 table))
95
96
97 (defstruct (word-table
98 (:print-function print-word-table))
99 "This structure is a word-table which is part of a Hemlock string-table."
100 (num-words 0 :type fixnum) ; Number of words
101 (words (make-array initial-word-table-size))) ; Array of WORD-ENTRY's
102
103 (defun print-word-table (table stream depth)
104 (declare (ignore table depth))
105 (format stream "#<Word Table>"))
106
107
108 (defstruct (word-entry
109 (:constructor make-word-entry (folded))
110 (:print-function print-word-entry))
111 "This structure is an entry in a word table which is part of a Hemlock
112 string-table."
113 next-table ; Pointer to next WORD-TABLE
114 folded ; Downcased word
115 value-node) ; Pointer to value node or NIL
116
117 (defun print-word-entry (entry stream depth)
118 (declare (ignore depth))
119 (format stream "#<Word Table Entry: \"~A\">" (word-entry-folded entry)))
120
121
122 (defstruct (value-node
123 (:constructor make-value-node (proper folded value))
124 (:print-function print-value-node))
125 "This structure is a node containing a value in a Hemlock string-table."
126 folded ; Downcased copy of string
127 proper ; Proper copy of string entry
128 value) ; Value of entry
129
130 (defun print-value-node (node stream depth)
131 (declare (ignore depth))
132 (format stream "<Value Node \"~A\">" (value-node-proper node)))
133
134
135 ;;;; Bi-SvPosition, String-Compare, String-Compare*
136
137 ;;; Much like the CL function POSITION; however, this is a fast binary
138 ;;; search for simple vectors. Vector must be a simple vector and Test
139 ;;; must be a function which returns either :equal, :less, or :greater.
140 ;;; (The vector must be sorted from lowest index to highest index by the
141 ;;; Test function.) Two values are returned: the first is the position
142 ;;; Item was found or if it was not found, where it should be inserted;
143 ;;; the second is a boolean flag indicating whether or not Item was
144 ;;; found.
145 ;;;
146 (defun bi-svposition (item vector test &key (start 0) end key)
147 (declare (simple-vector vector) (fixnum start))
148 (let ((low start)
149 (high (if end end (length vector)))
150 (mid 0))
151 (declare (fixnum low high mid))
152 (loop
153 (when (< high low) (return (values low nil)))
154 (setf mid (+ (the fixnum (ash (the fixnum (- high low)) -1)) low))
155 (let* ((array-item (svref vector mid))
156 (test-item (if key (funcall key array-item) array-item)))
157 (ecase (funcall test item test-item)
158 (:equal (return (values mid t)))
159 (:less (setf high (1- mid)))
160 (:greater (setf low (1+ mid))))))))
161
162 ;;; A simple-string comparison appropriate for use with BI-SVPOSITION.
163 ;;;
164 (defun string-compare (s1 s2 &key (start1 0) end1 (start2 0) end2)
165 (declare (simple-string s1 s2) (fixnum start1 start2))
166 (let* ((end1 (or end1 (length s1)))
167 (end2 (or end2 (length s2)))
168 (pos1 (string/= s1 s2
169 :start1 start1 :end1 end1 :start2 start2 :end2 end2)))
170 (if (null pos1)
171 :equal
172 (let ((pos2 (+ (the fixnum pos1) (- start2 start1))))
173 (declare (fixnum pos2))
174 (cond ((= pos1 (the fixnum end1)) :less)
175 ((= pos2 (the fixnum end2)) :greater)
176 ((char< (schar s1 (the fixnum pos1)) (schar s2 pos2)) :less)
177 (t :greater))))))
178
179 ;;; Macro to return a closure to call STRING-COMPARE with the given
180 ;;; keys.
181 ;;;
182 (defmacro string-compare* (&rest keys)
183 `#'(lambda (x y) (string-compare x y ,@keys)))
184
185
186 ;;;; Insert-Element, Nconcf
187
188 (eval-when (compile eval)
189
190 ;;; Insert-Element is a macro which encapsulates the hairiness of
191 ;;; inserting an element into a simple vector. Vector should be a
192 ;;; simple vector with Num elements (which may be less than or equal to
193 ;;; the length of the vector) and Element is the element to insert at
194 ;;; Pos. The optional argument Grow-Factor may be specified to control
195 ;;; the new size of the array if a new vector is necessary. The result
196 ;;; of INSERT-ELEMENT must be used as a new vector may be created.
197 ;;; (Note that the arguments should probably be lexicals since some of
198 ;;; them are evaluated more than once.)
199 ;;;
200 (defmacro insert-element (vector pos element num &optional (grow-factor 2))
201 `(let ((new-num (1+ ,num))
202 (max (length ,vector)))
203 (declare (fixnum new-num max))
204 (cond ((= ,num max)
205 ;; grow the vector
206 (let ((new (make-array (truncate (* max ,grow-factor)))))
207 (declare (simple-vector new))
208 ;; Blt the new buggers into place leaving a space for
209 ;; the new element
210 (replace new ,vector :end1 ,pos :end2 ,pos)
211 (replace new ,vector :start1 (1+ ,pos) :end1 new-num
212 :start2 ,pos :end2 ,num)
213 (setf (svref new ,pos) ,element)
214 new))
215 (t
216 ;; move the buggers down a slot
217 (replace ,vector ,vector :start1 (1+ ,pos) :start2 ,pos)
218 (setf (svref ,vector ,pos) ,element)
219 ,vector)))))
220
221 (define-modify-macro nconcf (&rest args) nconc)
222
223 ) ; eval-when
224
225
226 ;;;; With-Folded-String, Do-Words
227
228 ;;; With-Folded-String is a macro which deals with strings from the
229 ;;; user. First, if the original string is not a simple string then it
230 ;;; is coerced to one. Next, the string is trimmed using the separator
231 ;;; character and all separators between words are collapsed to a single
232 ;;; separator. The word boundaries are pushed on to a list so that the
233 ;;; Do-Words macro can be called anywhere within the dynamic extent of a
234 ;;; With-Folded-String to ``do'' over the words.
235
236 (defvar *string-buffer-size* 128)
237 (defvar *string-buffer* (make-string *string-buffer-size*))
238 (proclaim '(simple-string *string-buffer*))
239
240 (defvar *separator-positions* nil)
241
242 (eval-when (compile eval)
243
244 (defmacro do-words ((start-var end-var) &body (body decls))
245 (let ((sep-pos (gensym)))
246 `(dolist (,sep-pos *separator-positions*)
247 (let ((,start-var (car ,sep-pos))
248 (,end-var (cdr ,sep-pos)))
249 ,@decls
250 ,@body))))
251
252 (defmacro with-folded-string ((str-var len-var orig-str separator)
253 &body (body decls))
254 `(let ((,str-var *string-buffer*))
255 (declare (simple-string ,str-var))
256 ;; make the string simple if it isn't already
257 (unless (simple-string-p ,orig-str)
258 (setq ,orig-str (coerce ,orig-str 'simple-string)))
259 ;; munge it into *string-buffer* and do the body
260 (let ((,len-var (with-folded-munge-string ,orig-str ,separator)))
261 ,@decls
262 ,@body)))
263
264 ) ; eval-when
265
266 (defun with-folded-munge-string (str separator)
267 (declare (simple-string str) (base-character separator))
268 (let ((str-len (length str))
269 (sep-pos nil)
270 (buf-pos 0))
271 ;; Make sure we have enough room to blt the string into place.
272 (when (> str-len *string-buffer-size*)
273 (setq *string-buffer-size* (* str-len 2))
274 (setq *string-buffer* (make-string *string-buffer-size*)))
275 ;; Bash the spaces out of the string remembering where the words are.
276 (let ((start-pos (position separator str :test-not #'char=)))
277 (when start-pos
278 (loop
279 (let* ((end-pos (position separator str
280 :start start-pos :test #'char=))
281 (next-start-pos (and end-pos (position separator str
282 :start end-pos
283 :test-not #'char=)))
284 (word-len (- (or end-pos str-len) start-pos))
285 (new-buf-pos (+ buf-pos word-len)))
286 (replace *string-buffer* str
287 :start1 buf-pos :start2 start-pos :end2 end-pos)
288 (push (cons buf-pos new-buf-pos) sep-pos)
289 (setf buf-pos new-buf-pos)
290 (when (or (null end-pos) (null next-start-pos))
291 (return))
292 (setf start-pos next-start-pos)
293 (setf (schar *string-buffer* buf-pos) separator)
294 (incf buf-pos)))))
295 (nstring-downcase *string-buffer* :end buf-pos)
296 (setf *separator-positions* (nreverse sep-pos))
297 buf-pos))
298
299
300 ;;;; Getstring, Setf Method for Getstring
301
302 (defun getstring (string string-table)
303 "Looks up String in String-Table. Returns two values: the first is
304 the value of String or NIL if it does not exist; the second is a
305 boolean flag indicating whether or not String was found in
306 String-Table."
307 (with-folded-string (folded len string (string-table-separator string-table))
308 (let ((nodes (string-table-value-nodes string-table))
309 (num-nodes (string-table-num-nodes string-table)))
310 (declare (simple-vector nodes) (fixnum num-nodes))
311 (multiple-value-bind
312 (pos found-p)
313 (bi-svposition folded nodes (string-compare* :end1 len)
314 :end (1- num-nodes) :key #'value-node-folded)
315 (if found-p
316 (values (value-node-value (svref nodes pos)) t)
317 (values nil nil))))))
318
319 (defun %set-string-table (string table value)
320 "Sets the value of String in Table to Value. If necessary, creates
321 a new entry in the string table."
322 (with-folded-string (folded len string (string-table-separator table))
323 (when (zerop len)
324 (error "An empty string cannot be inserted into a string-table."))
325 (let ((nodes (string-table-value-nodes table))
326 (num-nodes (string-table-num-nodes table)))
327 (declare (simple-string folded) (simple-vector nodes) (fixnum num-nodes))
328 (multiple-value-bind
329 (pos found-p)
330 (bi-svposition folded nodes (string-compare* :end1 len)
331 :end (1- num-nodes) :key #'value-node-folded)
332 (cond (found-p
333 (setf (value-node-value (svref nodes pos)) value))
334 (t
335 ;; Note that a separator collapsed copy of string is NOT
336 ;; used here ...
337 ;;
338 (let ((node (make-value-node string (subseq folded 0 len) value))
339 (word-table (string-table-first-word-table table)))
340 ;; put in the value nodes array
341 (setf (string-table-value-nodes table)
342 (insert-element nodes pos node num-nodes))
343 (incf (string-table-num-nodes table))
344 ;; insert it into the word tree
345 (%set-insert-words folded word-table node))))))
346 value))
347
348 (defun %set-insert-words (folded first-word-table value-node)
349 (declare (simple-string folded))
350 (let ((word-table first-word-table)
351 (entry nil))
352 (do-words (word-start word-end)
353 (let ((word-array (word-table-words word-table))
354 (num-words (word-table-num-words word-table)))
355 (declare (simple-vector word-array) (fixnum num-words))
356 ;; find the entry or create a new one and insert it
357 (multiple-value-bind
358 (pos found-p)
359 (bi-svposition folded word-array
360 (string-compare* :start1 word-start :end1 word-end)
361 :end (1- num-words) :key #'word-entry-folded)
362 (declare (fixnum pos))
363 (cond (found-p
364 (setf entry (svref word-array pos)))
365 (t
366 (setf entry (make-word-entry
367 (subseq folded word-start word-end)))
368 (setf (word-table-words word-table)
369 (insert-element word-array pos entry num-words))
370 (incf (word-table-num-words word-table)))))
371 (let ((next-table (word-entry-next-table entry)))
372 (unless next-table
373 (setf next-table (make-word-table))
374 (setf (word-entry-next-table entry) next-table))
375 (setf word-table next-table))))
376 (setf (word-entry-value-node entry) value-node)))
377
378
379 ;;;; Find-Bound-Entries
380
381 (defun find-bound-entries (word-entries)
382 (let ((res nil))
383 (dolist (entry word-entries)
384 (nconcf res (sub-find-bound-entries entry)))
385 res))
386
387 (defun sub-find-bound-entries (entry)
388 (let ((bound-entries nil))
389 (when (word-entry-value-node entry) (push entry bound-entries))
390 (let ((next-table (word-entry-next-table entry)))
391 (when next-table
392 (let ((word-array (word-table-words next-table))
393 (num-words (word-table-num-words next-table)))
394 (declare (simple-vector word-array) (fixnum num-words))
395 (dotimes (i num-words)
396 (declare (fixnum i))
397 (nconcf bound-entries
398 (sub-find-bound-entries (svref word-array i)))))))
399 bound-entries))
400
401
402 ;;;; Find-Ambiguous
403
404 (defun find-ambiguous (string string-table)
405 "Returns a list, in alphabetical order, of all the strings in String-Table
406 which String matches."
407 (with-folded-string (folded len string (string-table-separator string-table))
408 (find-ambiguous* folded len string-table)))
409
410 (defun find-ambiguous* (folded len table)
411 (let ((word-table (string-table-first-word-table table))
412 (word-entries nil))
413 (cond ((zerop len)
414 (setf word-entries (find-ambiguous-entries "" 0 0 word-table)))
415 (t
416 (let ((word-tables (list word-table)))
417 (do-words (start end)
418 (setf word-entries nil)
419 (dolist (wt word-tables)
420 (nconcf word-entries
421 (find-ambiguous-entries folded start end wt)))
422 (unless word-entries (return))
423 (let ((next-word-tables nil))
424 (dolist (entry word-entries)
425 (let ((next-word-table (word-entry-next-table entry)))
426 (when next-word-table
427 (push next-word-table next-word-tables))))
428 (unless next-word-tables (return))
429 (setf word-tables (nreverse next-word-tables)))))))
430 (let ((bound-entries (find-bound-entries word-entries))
431 (res nil))
432 (dolist (be bound-entries)
433 (push (value-node-proper (word-entry-value-node be)) res))
434 (nreverse res))))
435
436 (defun find-ambiguous-entries (folded start end word-table)
437 (let ((word-array (word-table-words word-table))
438 (num-words (word-table-num-words word-table))
439 (res nil))
440 (declare (simple-vector word-array) (fixnum num-words))
441 (unless (zerop num-words)
442 (multiple-value-bind
443 (pos found-p)
444 (bi-svposition folded word-array
445 (string-compare* :start1 start :end1 end)
446 :end (1- num-words) :key #'word-entry-folded)
447 (declare (ignore found-p))
448 ;;
449 ;; Find last ambiguous string, checking for the end of the table.
450 (do ((i pos (1+ i)))
451 ((= i num-words))
452 (declare (fixnum i))
453 (let* ((entry (svref word-array i))
454 (str (word-entry-folded entry))
455 (str-len (length str))
456 (index (string/= folded str :start1 start :end1 end
457 :end2 str-len)))
458 (declare (simple-string str) (fixnum str-len))
459 (when (and index (/= index end)) (return nil))
460 (push entry res)))
461 (setf res (nreverse res))
462 ;;
463 ;; Scan back to the first string, checking for the beginning.
464 (do ((i (1- pos) (1- i)))
465 ((minusp i))
466 (declare (fixnum i))
467 (let* ((entry (svref word-array i))
468 (str (word-entry-folded entry))
469 (str-len (length str))
470 (index (string/= folded str :start1 start :end1 end
471 :end2 str-len)))
472 (declare (simple-string str) (fixnum str-len))
473 (when (and index (/= index end)) (return nil))
474 (push entry res)))))
475 res))
476
477
478 ;;;; Find-Containing
479
480 (defun find-containing (string string-table)
481 "Return a list in alphabetical order of all the strings in Table which
482 contain String as a substring."
483 (with-folded-string (folded len string (string-table-separator string-table))
484 (declare (ignore len))
485 (let ((word-table (string-table-first-word-table string-table))
486 (words nil))
487 ;; cons up a list of the words
488 (do-words (start end)
489 (push (subseq folded start end) words))
490 (setf words (nreverse words))
491 (let ((entries (sub-find-containing words word-table))
492 (res nil))
493 (dolist (e entries)
494 (push (value-node-proper (word-entry-value-node e)) res))
495 (nreverse res)))))
496
497 (defun sub-find-containing (words word-table)
498 (let ((res nil)
499 (word-array (word-table-words word-table))
500 (num-words (word-table-num-words word-table)))
501 (declare (simple-vector word-array) (fixnum num-words))
502 (dotimes (i num-words)
503 (declare (fixnum i))
504 (let* ((entry (svref word-array i))
505 (word (word-entry-folded entry))
506 (found (find word words
507 :test #'(lambda (y x)
508 (let ((lx (length x))
509 (ly (length y)))
510 (and (<= lx ly)
511 (string= x y :end2 lx))))))
512 (rest-words (if found
513 (remove found words :test #'eq :count 1)
514 words)))
515 (declare (simple-string word))
516 (cond (rest-words
517 (let ((next-table (word-entry-next-table entry)))
518 (when next-table
519 (nconcf res (sub-find-containing rest-words next-table)))))
520 (t
521 (nconcf res (sub-find-bound-entries entry))))))
522 res))
523
524
525 ;;;; Complete-String
526
527 (defvar *complete-string-buffer-size* 128)
528 (defvar *complete-string-buffer* (make-string *complete-string-buffer-size*))
529 (proclaim '(simple-string *complete-string-buffer*))
530
531 (defun complete-string (string tables)
532 "Attempts to complete the string String against the string tables in the
533 list Tables. Tables must all use the same separator character. See the
534 manual for details on return values."
535 (let ((separator (string-table-separator (car tables))))
536 #|(when (member separator (cdr tables)
537 :key #'string-table-separator :test-not #'char=)
538 (error "All tables must have the same separator."))|#
539 (with-folded-string (folded len string separator)
540 (let ((strings nil))
541 (dolist (table tables)
542 (nconcf strings (find-ambiguous* folded len table)))
543 ;; pick off easy case
544 (when (null strings)
545 (return-from complete-string (values nil :none nil nil nil)))
546 ;; grow complete-string buffer if necessary
547 (let ((size-needed (1+ len)))
548 (when (> size-needed *complete-string-buffer-size*)
549 (let* ((new-size (* size-needed 2))
550 (new-buffer (make-string new-size)))
551 (setf *complete-string-buffer* new-buffer)
552 (setf *complete-string-buffer-size* new-size))))
553 (multiple-value-bind
554 (str ambig-pos unique-p)
555 (find-longest-completion strings separator)
556 (multiple-value-bind (value found-p) (find-values str tables)
557 (let ((field-pos (compute-field-pos string str separator)))
558 (cond ((not found-p)
559 (values str :ambiguous nil field-pos ambig-pos))
560 (unique-p
561 (values str :unique value field-pos nil))
562 (t
563 (values str :complete value field-pos ambig-pos))))))))))
564
565 (defun find-values (string tables)
566 (dolist (table tables)
567 (multiple-value-bind (value found-p) (getstring string table)
568 (when found-p
569 (return-from find-values (values value t)))))
570 (values nil nil))
571
572 (defun compute-field-pos (given best separator)
573 (declare (simple-string given best) (base-character separator))
574 (let ((give-pos 0)
575 (best-pos 0))
576 (loop
577 (setf give-pos (position separator given :start give-pos :test #'char=))
578 (setf best-pos (position separator best :start best-pos :test #'char=))
579 (unless (and give-pos best-pos) (return best-pos))
580 (incf (the fixnum give-pos))
581 (incf (the fixnum best-pos)))))
582
583
584 ;;;; Find-Longest-Completion
585
586 (defun find-longest-completion (strings separator)
587 (declare (base-character separator))
588 (let ((first (car strings))
589 (rest-strings (cdr strings))
590 (punt-p nil)
591 (buf-pos 0)
592 (first-start 0)
593 (first-end -1)
594 (ambig-pos nil)
595 (maybe-unique-p nil))
596 (declare (simple-string first) (fixnum buf-pos first-start))
597 ;;
598 ;; Make room to store each string's next separator index.
599 (do ((l rest-strings (cdr l)))
600 ((endp l))
601 (setf (car l) (cons (car l) -1)))
602 ;;
603 ;; Compare the rest of the strings to the first one.
604 ;; It's our de facto standard for how far we can go.
605 (loop
606 (setf first-start (1+ first-end))
607 (setf first-end
608 (position separator first :start first-start :test #'char=))
609 (unless first-end
610 (setf first-end (length first))
611 (setf punt-p t)
612 (setf maybe-unique-p t))
613 (let ((first-max first-end)
614 (word-ambiguous-p nil))
615 (declare (fixnum first-max))
616 ;;
617 ;; For each string, store the separator's next index.
618 ;; If there's no separator, store nil and prepare to punt.
619 ;; If the string's field is not equal to the first's, shorten the max
620 ;; expectation for this field, and declare ambiguity.
621 (dolist (s rest-strings)
622 (let* ((str (car s))
623 (str-last-pos (cdr s))
624 (str-start (1+ str-last-pos))
625 (str-end (position separator str
626 :start str-start :test #'char=))
627 (index (string-not-equal first str
628 :start1 first-start :end1 first-max
629 :start2 str-start :end2 str-end)))
630 (declare (simple-string str) (fixnum str-last-pos str-start))
631 (setf (cdr s) str-end)
632 (unless str-end
633 (setf punt-p t)
634 (setf str-end (length str)))
635 (when index
636 (setf word-ambiguous-p t) ; not equal for some reason
637 (when (< index first-max)
638 (setf first-max index)))))
639 ;;
640 ;; Store what we matched into the result buffer and save the
641 ;; ambiguous position if its the first ambiguous field.
642 (let ((length (- first-max first-start)))
643 (declare (fixnum length))
644 (unless (zerop length)
645 (unless (zerop buf-pos)
646 (setf (schar *complete-string-buffer* buf-pos) separator)
647 (incf buf-pos))
648 (replace *complete-string-buffer* first
649 :start1 buf-pos :start2 first-start :end2 first-max)
650 (incf buf-pos length))
651 (when (and (null ambig-pos) word-ambiguous-p)
652 (setf ambig-pos buf-pos))
653 (when (or punt-p (zerop length)) (return)))))
654 (values
655 (subseq *complete-string-buffer* 0 buf-pos)
656 ;; If every corresponding field in each possible completion was equal,
657 ;; our result string is an initial substring of some other completion,
658 ;; so we're ambiguous at the end.
659 (or ambig-pos buf-pos)
660 (and (null ambig-pos)
661 maybe-unique-p
662 (every #'(lambda (x) (null (cdr x))) rest-strings)))))
663
664
665 ;;;; Clrstring
666
667 (defun clrstring (string-table)
668 "Delete all the entries in String-Table."
669 (fill (the simple-vector (string-table-value-nodes string-table)) nil)
670 (setf (string-table-num-nodes string-table) 0)
671 (let ((word-table (string-table-first-word-table string-table)))
672 (fill (the simple-vector (word-table-words word-table)) nil)
673 (setf (word-table-num-words word-table) 0))
674 t)
675
676
677 ;;;; Delete-String
678
679 (defun delete-string (string string-table)
680 (with-folded-string (folded len string (string-table-separator string-table))
681 (when (plusp len)
682 (let* ((nodes (string-table-value-nodes string-table))
683 (num-nodes (string-table-num-nodes string-table))
684 (end (1- num-nodes)))
685 (declare (simple-string folded) (simple-vector nodes)
686 (fixnum num-nodes end))
687 (multiple-value-bind
688 (pos found-p)
689 (bi-svposition folded nodes (string-compare* :end1 len)
690 :end end :key #'value-node-folded)
691 (cond (found-p
692 (replace nodes nodes
693 :start1 pos :end1 end :start2 (1+ pos) :end2 num-nodes)
694 (setf (svref nodes end) nil)
695 (setf (string-table-num-nodes string-table) end)
696 (sub-delete-string folded string-table)
697 t)
698 (t nil)))))))
699
700 (defun sub-delete-string (folded string-table)
701 (let ((next-table (string-table-first-word-table string-table))
702 (word-table nil)
703 (node nil)
704 (entry nil)
705 (level -1)
706 last-table last-table-level last-table-pos
707 last-entry last-entry-level)
708 (declare (fixnum level))
709 (do-words (start end)
710 (when node
711 (setf last-entry entry)
712 (setf last-entry-level level))
713 (setf word-table next-table)
714 (incf level)
715 (let ((word-array (word-table-words word-table))
716 (num-words (word-table-num-words word-table)))
717 (declare (simple-vector word-array) (fixnum num-words))
718 (multiple-value-bind
719 (pos found-p)
720 (bi-svposition folded word-array
721 (string-compare* :start1 start :end1 end)
722 :end (1- num-words) :key #'word-entry-folded)
723 (declare (fixnum pos) (ignore found-p))
724 (setf entry (svref word-array pos))
725 (setf next-table (word-entry-next-table entry))
726 (setf node (word-entry-value-node entry))
727 (when (or (null last-table) (> num-words 1))
728 (setf last-table word-table)
729 (setf last-table-pos pos)
730 (setf last-table-level level)))))
731 (cond (next-table
732 (setf (word-entry-value-node entry) nil))
733 ((and last-entry-level
734 (>= last-entry-level last-table-level))
735 (setf (word-entry-next-table last-entry) nil))
736 (t
737 (let* ((del-word-array (word-table-words last-table))
738 (del-num-words (word-table-num-words last-table))
739 (del-end (1- del-num-words)))
740 (declare (simple-vector del-word-array)
741 (fixnum del-num-words del-end))
742 (replace del-word-array del-word-array
743 :start1 last-table-pos :end1 del-end
744 :start2 (1+ last-table-pos)
745 :end2 del-num-words)
746 (setf (svref del-word-array del-end) nil)
747 (setf (word-table-num-words last-table) del-end))))))

  ViewVC Help
Powered by ViewVC 1.1.5