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

  ViewVC Help
Powered by ViewVC 1.1.5