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

Contents of /src/hemlock/table.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Sat Apr 19 20:52:42 2003 UTC (11 years ago) by gerd
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.4: +3 -3 lines
	Add destructuring support to &REST, &BODY, &WHOLE.  Detected
	by Paul Dietz' ANSI tests.

	* src/code/defmacro.lisp (parse-defmacro-lambda-list): Add
	&parse-body, replacing &body (<body> <decls> <doc>).  Add
	destructuring support to &rest, &body, &whole.

	* src/code/eval.lisp (lambda-list-keywords): Add &parse-body.

	* src/code/exports.lisp ("EXTENSIONS"): Export &parse-body.

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

  ViewVC Help
Powered by ViewVC 1.1.5