source: release/1.3/source/cocoa-ide/hemlock/src/table.lisp @ 12064

Last change on this file since 12064 was 12064, checked in by rme, 11 years ago

Merge r12061 to 1.3 (fix for ticket:472).

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