source: trunk/ccl/hemlock/src/table.lisp @ 6

Last change on this file since 6 was 6, checked in by gb, 16 years ago

Initial revision

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