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

Diff of /src/hemlock/table.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by ram, Wed May 9 13:06:29 1990 UTC revision 1.2 by ram, Fri Feb 11 21:54:00 1994 UTC
# Line 1  Line 1 
1  ;;; -*- Log: hemlock.log; Package: HEMLOCK-INTERNALS -*-  ;;; -*- Log: hemlock.log; Package: HEMLOCK-INTERNALS -*-
2  ;;;  ;;;
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the Spice Lisp project at  ;;; 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.  ;;; Carnegie Mellon University, and has been placed in the public domain.
6  ;;; Spice Lisp is currently incomplete and under active development.  ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7  ;;; If you want to use this code or any part of Spice Lisp, please contact  ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8  ;;; Scott Fahlman (Scott.Fahlman@CS.CMU.EDU).  ;;;
9    (ext:file-comment
10      "$Header$")
11    ;;;
12  ;;; **********************************************************************  ;;; **********************************************************************
13  ;;;  ;;;
14  ;;; Reluctantly written by Christopher Hoover  ;;; Reluctantly written by Christopher Hoover
# Line 62  Line 65 
65    
66  (defparameter initial-string-table-size 20  (defparameter initial-string-table-size 20
67    "Initial size of string table array for value nodes.")    "Initial size of string table array for value nodes.")
68  (defparameter initial-word-table-size 10  (defparameter initial-word-table-size 2
69    "Inital size of each word table array for each tree node.")    "Inital size of each word table array for each tree node.")
70    
71  (defstruct (string-table  (defstruct (string-table
# Line 70  Line 73 
73              (:print-function print-string-table))              (:print-function print-string-table))
74    "This structure is used to implement the Hemlock string-table type."    "This structure is used to implement the Hemlock string-table type."
75    ;; Character used to    ;; Character used to
76    (separator #\Space :type string-char)    ; character used for word separator    (separator #\Space :type base-char) ; character used for word separator
77    (num-nodes 0 :type fixnum)               ; number of nodes in string table    (num-nodes 0 :type fixnum)               ; number of nodes in string table
78    (value-nodes (make-array initial-string-table-size)) ; value node array    (value-nodes (make-array initial-string-table-size)) ; value node array
79    (first-word-table (make-word-table)))    ; pointer to first WORD-TABLE    (first-word-table (make-word-table)))    ; pointer to first WORD-TABLE
# Line 83  Line 86 
86    "Creates and returns a Hemlock string-table.  If Intitial-Contents is    "Creates and returns a Hemlock string-table.  If Intitial-Contents is
87    supplied in the form of an A-list of string-value pairs, these pairs    supplied in the form of an A-list of string-value pairs, these pairs
88    will be used to initialize the table.  If Separator, which must be a    will be used to initialize the table.  If Separator, which must be a
89    string-char, is specified then it will be used to distinguish word    base-char, is specified then it will be used to distinguish word
90    boundaries."    boundaries."
91    (let ((table (%make-string-table separator)))    (let ((table (%make-string-table separator)))
92      (dolist (x initial-contents)      (dolist (x initial-contents)
# Line 193  Line 196 
196  ;;; of INSERT-ELEMENT must be used as a new vector may be created.  ;;; of INSERT-ELEMENT must be used as a new vector may be created.
197  ;;; (Note that the arguments should probably be lexicals since some of  ;;; (Note that the arguments should probably be lexicals since some of
198  ;;; them are evaluated more than once.)  ;;; them are evaluated more than once.)
199    ;;;
200    ;;; We clear out the old vector so that it won't hold on to garbage if it
201    ;;; happens to be in static space.
202  ;;;  ;;;
203  (defmacro insert-element (vector pos element num &optional (grow-factor 2))  (defmacro insert-element (vector pos element num &optional (grow-factor 2))
204    `(let ((new-num (1+ ,num))    `(let ((new-num (1+ ,num))
# Line 207  Line 213 
213                (replace new ,vector :end1 ,pos :end2 ,pos)                (replace new ,vector :end1 ,pos :end2 ,pos)
214                (replace new ,vector :start1 (1+ ,pos) :end1 new-num                (replace new ,vector :start1 (1+ ,pos) :end1 new-num
215                         :start2 ,pos :end2 ,num)                         :start2 ,pos :end2 ,num)
216                  (fill ,vector nil)
217                (setf (svref new ,pos) ,element)                (setf (svref new ,pos) ,element)
218                new))                new))
219             (t             (t
220              ;; move the buggers down a slot              ;; move the buggers down a slot
221              (replace ,vector ,vector :start1 (1+ ,pos) :start2 ,pos)              (replace ,vector ,vector :start1 (1+ ,pos) :start2 ,pos)
222              (setf (svref ,vector ,pos) ,element)              (setf (svref ,vector ,pos) ,element)
223              ,vector)))))              ,vector))))
224    
225  (define-modify-macro nconcf (&rest args) nconc)  (define-modify-macro nconcf (&rest args) nconc)
226    
# Line 261  Line 268 
268  ) ; eval-when  ) ; eval-when
269    
270  (defun with-folded-munge-string (str separator)  (defun with-folded-munge-string (str separator)
271    (declare (simple-string str) (string-char separator))    (declare (simple-string str) (base-char separator))
272    (let ((str-len (length str))    (let ((str-len (length str))
273          (sep-pos nil)          (sep-pos nil)
274          (buf-pos 0))          (buf-pos 0))
# Line 567  Line 574 
574    (values nil nil))    (values nil nil))
575    
576  (defun compute-field-pos (given best separator)  (defun compute-field-pos (given best separator)
577    (declare (simple-string given best) (string-char separator))    (declare (simple-string given best) (base-char separator))
578    (let ((give-pos 0)    (let ((give-pos 0)
579          (best-pos 0))          (best-pos 0))
580      (loop      (loop
# Line 581  Line 588 
588  ;;;; Find-Longest-Completion  ;;;; Find-Longest-Completion
589    
590  (defun find-longest-completion (strings separator)  (defun find-longest-completion (strings separator)
591    (declare (string-char separator))    (declare (base-char separator))
592    (let ((first (car strings))    (let ((first (car strings))
593          (rest-strings (cdr strings))          (rest-strings (cdr strings))
594          (punt-p nil)          (punt-p nil)

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5