;;; -*- Log: hemlock.log; Package: Spell -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: spell-aug.lisp,v 1.1.1.2 91/02/08 16:37:44 ram Exp $") ;;; ;;; ********************************************************************** ;;; ;;; Written by Bill Chiles ;;; Designed by Bill Chiles and Rob Maclachlan ;;; ;;; This file contains the code to grow the spelling dictionary in system ;;; space by reading a text file of entries or adding one at a time. This ;;; code relies on implementation dependent code found in Spell-RT.Lisp. (in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM")) (export '(spell-add-entry spell-read-dictionary spell-remove-entry spell-root-flags)) ;;;; Converting Flags to Masks (defconstant flag-names-to-masks `((#\V . ,V-mask) (#\N . ,N-mask) (#\X . ,X-mask) (#\H . ,H-mask) (#\Y . ,Y-mask) (#\G . ,G-mask) (#\J . ,J-mask) (#\D . ,D-mask) (#\T . ,T-mask) (#\R . ,R-mask) (#\Z . ,Z-mask) (#\S . ,S-mask) (#\P . ,P-mask) (#\M . ,M-mask))) (defvar *flag-masks* (make-array 128 :element-type '(unsigned-byte 16) :initial-element 0) "This holds the masks for character flags, which is used when reading a text file of dictionary words. Illegal character flags hold zero.") (eval-when (compile eval) (defmacro flag-mask (char) `(aref *flag-masks* (char-code ,char))) ) ;eval-when (dolist (e flag-names-to-masks) (let ((char (car e)) (mask (cdr e))) (setf (flag-mask char) mask) (setf (flag-mask (char-downcase char)) mask))) ;;;; String and Hashing Macros (eval-when (compile eval) (defmacro string-table-replace (src-string dst-start length) `(sap-replace *string-table* ,src-string 0 ,dst-start (+ ,dst-start ,length))) ;;; HASH-ENTRY is used in SPELL-ADD-ENTRY to find a dictionary location for ;;; adding a new entry. If a location contains a zero, then it has never ;;; been used, and no entries have ever been "hashed past" it. If a location ;;; contains a -1, then it once contained an entry that has since been ;;; deleted. ;;; (defmacro hash-entry (entry entry-len) (let ((loop-loc (gensym)) (loc-contents (gensym)) (hash (gensym)) (loc (gensym))) `(let* ((,hash (string-hash ,entry ,entry-len)) (,loc (rem ,hash (the fixnum *dictionary-size*))) (,loc-contents (dictionary-ref ,loc))) (declare (fixnum ,loc ,loc-contents)) (if (or (zerop ,loc-contents) (= ,loc-contents -1)) ,loc (hash2-loop (,loop-loc ,loc-contents) ,loc ,hash ,loop-loc nil t))))) ) ;eval-when ;;;; Top Level Stuff (defun spell-read-dictionary (filename) "Add entries to dictionary from lines in the file filename." (with-open-file (s filename :direction :input) (loop (multiple-value-bind (entry eofp) (read-line s nil nil) (declare (type (or simple-string null) entry)) (unless entry (return)) (spell-add-entry entry) (if eofp (return)))))) ;;; This is used to break up an 18 bit string table index into two parts ;;; for storage in a word descriptor unit. See the documentation at the ;;; top of Spell-Correct.Lisp. ;;; (defconstant whole-index-low-byte (byte 16 0)) (defun spell-add-entry (line &optional (word-end (or (position #\/ line :test #'char=) (length line)))) "Line is of the form \"entry/flag1/flag2\" or \"entry\". It is parsed and added to the spelling dictionary. Line is desstructively modified." (declare (simple-string line) (fixnum word-end)) (nstring-upcase line :end word-end) (when (> word-end max-entry-length) (return-from spell-add-entry nil)) (let ((entry (lookup-entry line word-end))) (when entry (add-flags (+ entry 2) line word-end) (return-from spell-add-entry nil))) (let* ((hash-loc (hash-entry line word-end)) (string-ptr *string-table-size*) (desc-ptr *descriptors-size*) (desc-ptr+1 (1+ desc-ptr)) (desc-ptr+2 (1+ desc-ptr+1))) (declare (fixnum string-ptr)) (when (not hash-loc) (error "Dictionary Overflow!")) (when (> 3 *free-descriptor-elements*) (grow-descriptors)) (when (> word-end *free-string-table-bytes*) (grow-string-table)) (decf *free-descriptor-elements* 3) (incf *descriptors-size* 3) (decf *free-string-table-bytes* word-end) (incf *string-table-size* word-end) (setf (dictionary-ref hash-loc) desc-ptr) (setf (descriptor-ref desc-ptr) (dpb (the fixnum (ldb new-hash-byte (string-hash line word-end))) stored-hash-byte word-end)) (setf (descriptor-ref desc-ptr+1) (ldb whole-index-low-byte string-ptr)) (setf (descriptor-ref desc-ptr+2) (dpb (the fixnum (ldb whole-index-high-byte string-ptr)) stored-index-high-byte 0)) (add-flags desc-ptr+2 line word-end) (string-table-replace line string-ptr word-end)) t) (defun add-flags (loc line word-end) (declare (simple-string line) (fixnum word-end)) (do ((flag (1+ word-end) (+ 2 flag)) (line-end (length line))) ((>= flag line-end)) (declare (fixnum flag line-end)) (let ((flag-mask (flag-mask (schar line flag)))) (declare (fixnum flag-mask)) (unless (zerop flag-mask) (setf (descriptor-ref loc) (logior flag-mask (descriptor-ref loc))))))) ;;; SPELL-REMOVE-ENTRY destructively uppercases entry in removing it from ;;; the dictionary. First entry is looked up, and if it is found due to a ;;; flag, the flag is cleared in the descriptor table. If entry is a root ;;; word in the dictionary (that is, looked up without the use of a flag), ;;; then the root and all its derivitives are deleted by setting its ;;; dictionary location to -1. ;;; (defun spell-remove-entry (entry) "Removes entry from the dictionary, so it will be an unknown word. Entry is a simple string and is destructively modified. If entry is a root word, then all words derived with entry and its flags will also be deleted." (declare (simple-string entry)) (nstring-upcase entry) (let ((entry-len (length entry))) (declare (fixnum entry-len)) (when (<= 2 entry-len max-entry-length) (multiple-value-bind (index flagp) (spell-try-word entry entry-len) (when index (if flagp (setf (descriptor-ref (+ 2 index)) (logandc2 (descriptor-ref (+ 2 index)) flagp)) (let* ((hash (string-hash entry entry-len)) (hash-and-len (dpb (the fixnum (ldb new-hash-byte hash)) stored-hash-byte (the fixnum entry-len))) (loc (rem hash (the fixnum *dictionary-size*))) (loc-contents (dictionary-ref loc))) (declare (fixnum hash hash-and-len loc)) (cond ((zerop loc-contents) nil) ((found-entry-p loc-contents entry entry-len hash-and-len) (setf (dictionary-ref loc) -1)) (t (hash2-loop (loop-loc loc-contents) loc hash nil (when (found-entry-p loc-contents entry entry-len hash-and-len) (setf (dictionary-ref loop-loc) -1) (return -1)))))))))))) (defun spell-root-flags (index) "Return the flags associated with the root word corresponding to a dictionary entry at index." (let ((desc-word (descriptor-ref (+ 2 index))) (result ())) (declare (fixnum desc-word)) (dolist (ele flag-names-to-masks result) (unless (zerop (logand (the fixnum (cdr ele)) desc-word)) (push (car ele) result))))) ;;;; Growing Dictionary Structures ;;; GROW-DESCRIPTORS grows the descriptors vector by 10%. ;;; (defun grow-descriptors () (let* ((old-size (+ (the fixnum *descriptors-size*) (the fixnum *free-descriptor-elements*))) (new-size (truncate (* old-size 1.1))) (new-bytes (* new-size 2)) (new-sap (allocate-bytes new-bytes))) (declare (fixnum new-size old-size)) (sap-replace new-sap *descriptors* 0 0 (* 2 (the fixnum *descriptors-size*))) (deallocate-bytes (system-address *descriptors*) (* 2 old-size)) (setf *free-descriptor-elements* (- new-size (the fixnum *descriptors-size*))) (setf *descriptors* new-sap))) ;;; GROW-STRING-TABLE grows the string table by 10%. ;;; (defun grow-string-table () (let* ((old-size (+ (the fixnum *string-table-size*) (the fixnum *free-string-table-bytes*))) (new-size (truncate (* old-size 1.1))) (new-sap (allocate-bytes new-size))) (declare (fixnum new-size old-size)) (sap-replace new-sap *string-table* 0 0 *string-table-size*) (setf *free-string-table-bytes* (- new-size (the fixnum *string-table-size*))) (deallocate-bytes (system-address *string-table*) old-size) (setf *string-table* new-sap)))