/[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.5 - (show annotations) (vendor branch)
Fri Dec 20 18:25:28 1991 UTC (22 years, 4 months ago) by ram
Changes since 1.1.1.4: +5 -1 lines
When we reallocate vectors to grow them, clear the old vector so that it won't
hold onto garbage (in case the vector was in static space, but pointed to
dynamic values.)  This was a major cause of memory leakage in Hemlock.
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.5 1991/12/20 18:25:28 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-char) ; 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-char, 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 ;;; We clear out the old vector so that it won't hold on to garbage if it
201 ;;; happens to be in static space.
202 ;;;
203 (defmacro insert-element (vector pos element num &optional (grow-factor 2))
204 `(let ((new-num (1+ ,num))
205 (max (length ,vector)))
206 (declare (fixnum new-num max))
207 (cond ((= ,num max)
208 ;; grow the vector
209 (let ((new (make-array (truncate (* max ,grow-factor)))))
210 (declare (simple-vector new))
211 ;; Blt the new buggers into place leaving a space for
212 ;; the new element
213 (replace new ,vector :end1 ,pos :end2 ,pos)
214 (replace new ,vector :start1 (1+ ,pos) :end1 new-num
215 :start2 ,pos :end2 ,num)
216 (fill ,vector nil)
217 (setf (svref new ,pos) ,element)
218 new))
219 (t
220 ;; move the buggers down a slot
221 (replace ,vector ,vector :start1 (1+ ,pos) :start2 ,pos)
222 (setf (svref ,vector ,pos) ,element)
223 ,vector)))))
224
225 (define-modify-macro nconcf (&rest args) nconc)
226
227 ) ; eval-when
228
229
230 ;;;; With-Folded-String, Do-Words
231
232 ;;; With-Folded-String is a macro which deals with strings from the
233 ;;; user. First, if the original string is not a simple string then it
234 ;;; is coerced to one. Next, the string is trimmed using the separator
235 ;;; character and all separators between words are collapsed to a single
236 ;;; separator. The word boundaries are pushed on to a list so that the
237 ;;; Do-Words macro can be called anywhere within the dynamic extent of a
238 ;;; With-Folded-String to ``do'' over the words.
239
240 (defvar *string-buffer-size* 128)
241 (defvar *string-buffer* (make-string *string-buffer-size*))
242 (proclaim '(simple-string *string-buffer*))
243
244 (defvar *separator-positions* nil)
245
246 (eval-when (compile eval)
247
248 (defmacro do-words ((start-var end-var) &body (body decls))
249 (let ((sep-pos (gensym)))
250 `(dolist (,sep-pos *separator-positions*)
251 (let ((,start-var (car ,sep-pos))
252 (,end-var (cdr ,sep-pos)))
253 ,@decls
254 ,@body))))
255
256 (defmacro with-folded-string ((str-var len-var orig-str separator)
257 &body (body decls))
258 `(let ((,str-var *string-buffer*))
259 (declare (simple-string ,str-var))
260 ;; make the string simple if it isn't already
261 (unless (simple-string-p ,orig-str)
262 (setq ,orig-str (coerce ,orig-str 'simple-string)))
263 ;; munge it into *string-buffer* and do the body
264 (let ((,len-var (with-folded-munge-string ,orig-str ,separator)))
265 ,@decls
266 ,@body)))
267
268 ) ; eval-when
269
270 (defun with-folded-munge-string (str separator)
271 (declare (simple-string str) (base-char separator))
272 (let ((str-len (length str))
273 (sep-pos nil)
274 (buf-pos 0))
275 ;; Make sure we have enough room to blt the string into place.
276 (when (> str-len *string-buffer-size*)
277 (setq *string-buffer-size* (* str-len 2))
278 (setq *string-buffer* (make-string *string-buffer-size*)))
279 ;; Bash the spaces out of the string remembering where the words are.
280 (let ((start-pos (position separator str :test-not #'char=)))
281 (when start-pos
282 (loop
283 (let* ((end-pos (position separator str
284 :start start-pos :test #'char=))
285 (next-start-pos (and end-pos (position separator str
286 :start end-pos
287 :test-not #'char=)))
288 (word-len (- (or end-pos str-len) start-pos))
289 (new-buf-pos (+ buf-pos word-len)))
290 (replace *string-buffer* str
291 :start1 buf-pos :start2 start-pos :end2 end-pos)
292 (push (cons buf-pos new-buf-pos) sep-pos)
293 (setf buf-pos new-buf-pos)
294 (when (or (null end-pos) (null next-start-pos))
295 (return))
296 (setf start-pos next-start-pos)
297 (setf (schar *string-buffer* buf-pos) separator)
298 (incf buf-pos)))))
299 (nstring-downcase *string-buffer* :end buf-pos)
300 (setf *separator-positions* (nreverse sep-pos))
301 buf-pos))
302
303
304 ;;;; Getstring, Setf Method for Getstring
305
306 (defun getstring (string string-table)
307 "Looks up String in String-Table. Returns two values: the first is
308 the value of String or NIL if it does not exist; the second is a
309 boolean flag indicating whether or not String was found in
310 String-Table."
311 (with-folded-string (folded len string (string-table-separator string-table))
312 (let ((nodes (string-table-value-nodes string-table))
313 (num-nodes (string-table-num-nodes string-table)))
314 (declare (simple-vector nodes) (fixnum num-nodes))
315 (multiple-value-bind
316 (pos found-p)
317 (bi-svposition folded nodes (string-compare* :end1 len)
318 :end (1- num-nodes) :key #'value-node-folded)
319 (if found-p
320 (values (value-node-value (svref nodes pos)) t)
321 (values nil nil))))))
322
323 (defun %set-string-table (string table value)
324 "Sets the value of String in Table to Value. If necessary, creates
325 a new entry in the string table."
326 (with-folded-string (folded len string (string-table-separator table))
327 (when (zerop len)
328 (error "An empty string cannot be inserted into a string-table."))
329 (let ((nodes (string-table-value-nodes table))
330 (num-nodes (string-table-num-nodes table)))
331 (declare (simple-string folded) (simple-vector nodes) (fixnum num-nodes))
332 (multiple-value-bind
333 (pos found-p)
334 (bi-svposition folded nodes (string-compare* :end1 len)
335 :end (1- num-nodes) :key #'value-node-folded)
336 (cond (found-p
337 (setf (value-node-value (svref nodes pos)) value))
338 (t
339 ;; Note that a separator collapsed copy of string is NOT
340 ;; used here ...
341 ;;
342 (let ((node (make-value-node string (subseq folded 0 len) value))
343 (word-table (string-table-first-word-table table)))
344 ;; put in the value nodes array
345 (setf (string-table-value-nodes table)
346 (insert-element nodes pos node num-nodes))
347 (incf (string-table-num-nodes table))
348 ;; insert it into the word tree
349 (%set-insert-words folded word-table node))))))
350 value))
351
352 (defun %set-insert-words (folded first-word-table value-node)
353 (declare (simple-string folded))
354 (let ((word-table first-word-table)
355 (entry nil))
356 (do-words (word-start word-end)
357 (let ((word-array (word-table-words word-table))
358 (num-words (word-table-num-words word-table)))
359 (declare (simple-vector word-array) (fixnum num-words))
360 ;; find the entry or create a new one and insert it
361 (multiple-value-bind
362 (pos found-p)
363 (bi-svposition folded word-array
364 (string-compare* :start1 word-start :end1 word-end)
365 :end (1- num-words) :key #'word-entry-folded)
366 (declare (fixnum pos))
367 (cond (found-p
368 (setf entry (svref word-array pos)))
369 (t
370 (setf entry (make-word-entry
371 (subseq folded word-start word-end)))
372 (setf (word-table-words word-table)
373 (insert-element word-array pos entry num-words))
374 (incf (word-table-num-words word-table)))))
375 (let ((next-table (word-entry-next-table entry)))
376 (unless next-table
377 (setf next-table (make-word-table))
378 (setf (word-entry-next-table entry) next-table))
379 (setf word-table next-table))))
380 (setf (word-entry-value-node entry) value-node)))
381
382
383 ;;;; Find-Bound-Entries
384
385 (defun find-bound-entries (word-entries)
386 (let ((res nil))
387 (dolist (entry word-entries)
388 (nconcf res (sub-find-bound-entries entry)))
389 res))
390
391 (defun sub-find-bound-entries (entry)
392 (let ((bound-entries nil))
393 (when (word-entry-value-node entry) (push entry bound-entries))
394 (let ((next-table (word-entry-next-table entry)))
395 (when next-table
396 (let ((word-array (word-table-words next-table))
397 (num-words (word-table-num-words next-table)))
398 (declare (simple-vector word-array) (fixnum num-words))
399 (dotimes (i num-words)
400 (declare (fixnum i))
401 (nconcf bound-entries
402 (sub-find-bound-entries (svref word-array i)))))))
403 bound-entries))
404
405
406 ;;;; Find-Ambiguous
407
408 (defun find-ambiguous (string string-table)
409 "Returns a list, in alphabetical order, of all the strings in String-Table
410 which String matches."
411 (with-folded-string (folded len string (string-table-separator string-table))
412 (find-ambiguous* folded len string-table)))
413
414 (defun find-ambiguous* (folded len table)
415 (let ((word-table (string-table-first-word-table table))
416 (word-entries nil))
417 (cond ((zerop len)
418 (setf word-entries (find-ambiguous-entries "" 0 0 word-table)))
419 (t
420 (let ((word-tables (list word-table)))
421 (do-words (start end)
422 (setf word-entries nil)
423 (dolist (wt word-tables)
424 (nconcf word-entries
425 (find-ambiguous-entries folded start end wt)))
426 (unless word-entries (return))
427 (let ((next-word-tables nil))
428 (dolist (entry word-entries)
429 (let ((next-word-table (word-entry-next-table entry)))
430 (when next-word-table
431 (push next-word-table next-word-tables))))
432 (unless next-word-tables (return))
433 (setf word-tables (nreverse next-word-tables)))))))
434 (let ((bound-entries (find-bound-entries word-entries))
435 (res nil))
436 (dolist (be bound-entries)
437 (push (value-node-proper (word-entry-value-node be)) res))
438 (nreverse res))))
439
440 (defun find-ambiguous-entries (folded start end word-table)
441 (let ((word-array (word-table-words word-table))
442 (num-words (word-table-num-words word-table))
443 (res nil))
444 (declare (simple-vector word-array) (fixnum num-words))
445 (unless (zerop num-words)
446 (multiple-value-bind
447 (pos found-p)
448 (bi-svposition folded word-array
449 (string-compare* :start1 start :end1 end)
450 :end (1- num-words) :key #'word-entry-folded)
451 (declare (ignore found-p))
452 ;;
453 ;; Find last ambiguous string, checking for the end of the table.
454 (do ((i pos (1+ i)))
455 ((= i num-words))
456 (declare (fixnum i))
457 (let* ((entry (svref word-array i))
458 (str (word-entry-folded entry))
459 (str-len (length str))
460 (index (string/= folded str :start1 start :end1 end
461 :end2 str-len)))
462 (declare (simple-string str) (fixnum str-len))
463 (when (and index (/= index end)) (return nil))
464 (push entry res)))
465 (setf res (nreverse res))
466 ;;
467 ;; Scan back to the first string, checking for the beginning.
468 (do ((i (1- pos) (1- i)))
469 ((minusp i))
470 (declare (fixnum i))
471 (let* ((entry (svref word-array i))
472 (str (word-entry-folded entry))
473 (str-len (length str))
474 (index (string/= folded str :start1 start :end1 end
475 :end2 str-len)))
476 (declare (simple-string str) (fixnum str-len))
477 (when (and index (/= index end)) (return nil))
478 (push entry res)))))
479 res))
480
481
482 ;;;; Find-Containing
483
484 (defun find-containing (string string-table)
485 "Return a list in alphabetical order of all the strings in Table which
486 contain String as a substring."
487 (with-folded-string (folded len string (string-table-separator string-table))
488 (declare (ignore len))
489 (let ((word-table (string-table-first-word-table string-table))
490 (words nil))
491 ;; cons up a list of the words
492 (do-words (start end)
493 (push (subseq folded start end) words))
494 (setf words (nreverse words))
495 (let ((entries (sub-find-containing words word-table))
496 (res nil))
497 (dolist (e entries)
498 (push (value-node-proper (word-entry-value-node e)) res))
499 (nreverse res)))))
500
501 (defun sub-find-containing (words word-table)
502 (let ((res nil)
503 (word-array (word-table-words word-table))
504 (num-words (word-table-num-words word-table)))
505 (declare (simple-vector word-array) (fixnum num-words))
506 (dotimes (i num-words)
507 (declare (fixnum i))
508 (let* ((entry (svref word-array i))
509 (word (word-entry-folded entry))
510 (found (find word words
511 :test #'(lambda (y x)
512 (let ((lx (length x))
513 (ly (length y)))
514 (and (<= lx ly)
515 (string= x y :end2 lx))))))
516 (rest-words (if found
517 (remove found words :test #'eq :count 1)
518 words)))
519 (declare (simple-string word))
520 (cond (rest-words
521 (let ((next-table (word-entry-next-table entry)))
522 (when next-table
523 (nconcf res (sub-find-containing rest-words next-table)))))
524 (t
525 (nconcf res (sub-find-bound-entries entry))))))
526 res))
527
528
529 ;;;; Complete-String
530
531 (defvar *complete-string-buffer-size* 128)
532 (defvar *complete-string-buffer* (make-string *complete-string-buffer-size*))
533 (proclaim '(simple-string *complete-string-buffer*))
534
535 (defun complete-string (string tables)
536 "Attempts to complete the string String against the string tables in the
537 list Tables. Tables must all use the same separator character. See the
538 manual for details on return values."
539 (let ((separator (string-table-separator (car tables))))
540 #|(when (member separator (cdr tables)
541 :key #'string-table-separator :test-not #'char=)
542 (error "All tables must have the same separator."))|#
543 (with-folded-string (folded len string separator)
544 (let ((strings nil))
545 (dolist (table tables)
546 (nconcf strings (find-ambiguous* folded len table)))
547 ;; pick off easy case
548 (when (null strings)
549 (return-from complete-string (values nil :none nil nil nil)))
550 ;; grow complete-string buffer if necessary
551 (let ((size-needed (1+ len)))
552 (when (> size-needed *complete-string-buffer-size*)
553 (let* ((new-size (* size-needed 2))
554 (new-buffer (make-string new-size)))
555 (setf *complete-string-buffer* new-buffer)
556 (setf *complete-string-buffer-size* new-size))))
557 (multiple-value-bind
558 (str ambig-pos unique-p)
559 (find-longest-completion strings separator)
560 (multiple-value-bind (value found-p) (find-values str tables)
561 (let ((field-pos (compute-field-pos string str separator)))
562 (cond ((not found-p)
563 (values str :ambiguous nil field-pos ambig-pos))
564 (unique-p
565 (values str :unique value field-pos nil))
566 (t
567 (values str :complete value field-pos ambig-pos))))))))))
568
569 (defun find-values (string tables)
570 (dolist (table tables)
571 (multiple-value-bind (value found-p) (getstring string table)
572 (when found-p
573 (return-from find-values (values value t)))))
574 (values nil nil))
575
576 (defun compute-field-pos (given best separator)
577 (declare (simple-string given best) (base-char separator))
578 (let ((give-pos 0)
579 (best-pos 0))
580 (loop
581 (setf give-pos (position separator given :start give-pos :test #'char=))
582 (setf best-pos (position separator best :start best-pos :test #'char=))
583 (unless (and give-pos best-pos) (return best-pos))
584 (incf (the fixnum give-pos))
585 (incf (the fixnum best-pos)))))
586
587
588 ;;;; Find-Longest-Completion
589
590 (defun find-longest-completion (strings separator)
591 (declare (base-char separator))
592 (let ((first (car strings))
593 (rest-strings (cdr strings))
594 (punt-p nil)
595 (buf-pos 0)
596 (first-start 0)
597 (first-end -1)
598 (ambig-pos nil)
599 (maybe-unique-p nil))
600 (declare (simple-string first) (fixnum buf-pos first-start))
601 ;;
602 ;; Make room to store each string's next separator index.
603 (do ((l rest-strings (cdr l)))
604 ((endp l))
605 (setf (car l) (cons (car l) -1)))
606 ;;
607 ;; Compare the rest of the strings to the first one.
608 ;; It's our de facto standard for how far we can go.
609 (loop
610 (setf first-start (1+ first-end))
611 (setf first-end
612 (position separator first :start first-start :test #'char=))
613 (unless first-end
614 (setf first-end (length first))
615 (setf punt-p t)
616 (setf maybe-unique-p t))
617 (let ((first-max first-end)
618 (word-ambiguous-p nil))
619 (declare (fixnum first-max))
620 ;;
621 ;; For each string, store the separator's next index.
622 ;; If there's no separator, store nil and prepare to punt.
623 ;; If the string's field is not equal to the first's, shorten the max
624 ;; expectation for this field, and declare ambiguity.
625 (dolist (s rest-strings)
626 (let* ((str (car s))
627 (str-last-pos (cdr s))
628 (str-start (1+ str-last-pos))
629 (str-end (position separator str
630 :start str-start :test #'char=))
631 (index (string-not-equal first str
632 :start1 first-start :end1 first-max
633 :start2 str-start :end2 str-end)))
634 (declare (simple-string str) (fixnum str-last-pos str-start))
635 (setf (cdr s) str-end)
636 (unless str-end
637 (setf punt-p t)
638 (setf str-end (length str)))
639 (when index
640 (setf word-ambiguous-p t) ; not equal for some reason
641 (when (< index first-max)
642 (setf first-max index)))))
643 ;;
644 ;; Store what we matched into the result buffer and save the
645 ;; ambiguous position if its the first ambiguous field.
646 (let ((length (- first-max first-start)))
647 (declare (fixnum length))
648 (unless (zerop length)
649 (unless (zerop buf-pos)
650 (setf (schar *complete-string-buffer* buf-pos) separator)
651 (incf buf-pos))
652 (replace *complete-string-buffer* first
653 :start1 buf-pos :start2 first-start :end2 first-max)
654 (incf buf-pos length))
655 (when (and (null ambig-pos) word-ambiguous-p)
656 (setf ambig-pos buf-pos))
657 (when (or punt-p (zerop length)) (return)))))
658 (values
659 (subseq *complete-string-buffer* 0 buf-pos)
660 ;; If every corresponding field in each possible completion was equal,
661 ;; our result string is an initial substring of some other completion,
662 ;; so we're ambiguous at the end.
663 (or ambig-pos buf-pos)
664 (and (null ambig-pos)
665 maybe-unique-p
666 (every #'(lambda (x) (null (cdr x))) rest-strings)))))
667
668
669 ;;;; Clrstring
670
671 (defun clrstring (string-table)
672 "Delete all the entries in String-Table."
673 (fill (the simple-vector (string-table-value-nodes string-table)) nil)
674 (setf (string-table-num-nodes string-table) 0)
675 (let ((word-table (string-table-first-word-table string-table)))
676 (fill (the simple-vector (word-table-words word-table)) nil)
677 (setf (word-table-num-words word-table) 0))
678 t)
679
680
681 ;;;; Delete-String
682
683 (defun delete-string (string string-table)
684 (with-folded-string (folded len string (string-table-separator string-table))
685 (when (plusp len)
686 (let* ((nodes (string-table-value-nodes string-table))
687 (num-nodes (string-table-num-nodes string-table))
688 (end (1- num-nodes)))
689 (declare (simple-string folded) (simple-vector nodes)
690 (fixnum num-nodes end))
691 (multiple-value-bind
692 (pos found-p)
693 (bi-svposition folded nodes (string-compare* :end1 len)
694 :end end :key #'value-node-folded)
695 (cond (found-p
696 (replace nodes nodes
697 :start1 pos :end1 end :start2 (1+ pos) :end2 num-nodes)
698 (setf (svref nodes end) nil)
699 (setf (string-table-num-nodes string-table) end)
700 (sub-delete-string folded string-table)
701 t)
702 (t nil)))))))
703
704 (defun sub-delete-string (folded string-table)
705 (let ((next-table (string-table-first-word-table string-table))
706 (word-table nil)
707 (node nil)
708 (entry nil)
709 (level -1)
710 last-table last-table-level last-table-pos
711 last-entry last-entry-level)
712 (declare (fixnum level))
713 (do-words (start end)
714 (when node
715 (setf last-entry entry)
716 (setf last-entry-level level))
717 (setf word-table next-table)
718 (incf level)
719 (let ((word-array (word-table-words word-table))
720 (num-words (word-table-num-words word-table)))
721 (declare (simple-vector word-array) (fixnum num-words))
722 (multiple-value-bind
723 (pos found-p)
724 (bi-svposition folded word-array
725 (string-compare* :start1 start :end1 end)
726 :end (1- num-words) :key #'word-entry-folded)
727 (declare (fixnum pos) (ignore found-p))
728 (setf entry (svref word-array pos))
729 (setf next-table (word-entry-next-table entry))
730 (setf node (word-entry-value-node entry))
731 (when (or (null last-table) (> num-words 1))
732 (setf last-table word-table)
733 (setf last-table-pos pos)
734 (setf last-table-level level)))))
735 (cond (next-table
736 (setf (word-entry-value-node entry) nil))
737 ((and last-entry-level
738 (>= last-entry-level last-table-level))
739 (setf (word-entry-next-table last-entry) nil))
740 (t
741 (let* ((del-word-array (word-table-words last-table))
742 (del-num-words (word-table-num-words last-table))
743 (del-end (1- del-num-words)))
744 (declare (simple-vector del-word-array)
745 (fixnum del-num-words del-end))
746 (replace del-word-array del-word-array
747 :start1 last-table-pos :end1 del-end
748 :start2 (1+ last-table-pos)
749 :end2 del-num-words)
750 (setf (svref del-word-array del-end) nil)
751 (setf (word-table-num-words last-table) del-end))))))

  ViewVC Help
Powered by ViewVC 1.1.5