Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv12616 Modified Files: syntax.lisp Log Message: slight improvement in speed to syntax.lisp (though not enough): Cache in the grammar which rules are applicable to which symbols. Make ITEM-EQUAL a regular function. A couple of folorn (optimize speed)s and type declarations, which don't actually help all that much. Date: Thu Apr 14 10:13:18 2005 Author: crhodes Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.41 climacs/syntax.lisp:1.42 --- climacs/syntax.lisp:1.41 Fri Mar 18 08:49:17 2005 +++ climacs/syntax.lisp Thu Apr 14 10:13:18 2005 @@ -207,7 +207,8 @@ (symbols :initarg :symbols :reader symbols))) (defclass grammar () - ((rules :initarg :rules :accessor rules))) + ((rules :initform nil :accessor rules) + (hash :initform (make-hash-table) :accessor hash))) (defmacro grammar-rule ((left-hand-side arrow arglist &body body)) (declare (ignore arrow)) @@ -245,14 +246,29 @@ (defmacro grammar (&body body) - `(make-instance 'grammar - :rules (list ,@(loop for rule in body - collect `(grammar-rule ,rule))))) + (let ((rule (gensym "RULE")) + (rules (gensym "RULES")) + (result (gensym "RESULT"))) + `(let* ((,rules (list ,@(loop for rule in body + collect `(grammar-rule ,rule)))) + (,result (make-instance 'grammar))) + (dolist (,rule ,rules ,result) + (add-rule ,rule ,result))))) (defgeneric add-rule (rule grammar)) (defmethod add-rule (rule (grammar grammar)) - (push rule (rules grammar))) + (push rule (rules grammar)) + (clrhash (hash grammar)) + (let (rhs-symbols) + (dolist (rule (rules grammar)) + (setf rhs-symbols (union rhs-symbols (coerce (symbols rule) 'list)))) + (dolist (rule (rules grammar)) + (let ((lhs-symbol (left-hand-side rule))) + (dolist (rhs-symbol rhs-symbols) + (when (or (subtypep lhs-symbol rhs-symbol) + (subtypep rhs-symbol lhs-symbol)) + (pushnew rule (gethash rhs-symbol (hash grammar))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -316,19 +332,18 @@ :parse-tree remaining :parse-trees parse-trees))))))) -(defgeneric item-equal (item1 item2)) - -(defgeneric parse-tree-equal (tree1 tree2)) - -(defmethod item-equal ((item1 rule-item) (item2 rule-item)) - nil) - -(defmethod item-equal ((item1 incomplete-item) (item2 incomplete-item)) +(defun item-equal (item1 item2) + (declare (optimize speed)) (and (eq (rule item1) (rule item2)) - (eq (length (parse-trees item1)) (length (parse-trees item2))) - (every #'parse-tree-equal (parse-trees item1) (parse-trees item2)))) + (do ((trees1 (parse-trees item1) (cdr trees1)) + (trees2 (parse-trees item2) (cdr trees2))) + ((and (null trees1) (null trees2)) t) + (when (or (null trees1) (null trees2)) + (return nil)) + (when (not (parse-tree-equal (car trees1) (car trees2))) + (return nil))))) -(defmethod parse-tree-equal (tree1 tree2) +(defun parse-tree-equal (tree1 tree2) (eq (class-of tree1) (class-of tree2))) (defgeneric parse-tree-better (tree1 tree2)) @@ -376,25 +391,24 @@ nil) (defmethod handle-item ((item incomplete-item) orig-state to-state) - (cond ((find item (gethash orig-state (incomplete-items to-state)) + (declare (optimize speed)) + (cond ((find item (the list (gethash orig-state (incomplete-items to-state))) :test #'item-equal) nil) (t (push item (gethash orig-state (incomplete-items to-state))) - (loop for rule in (rules (parser-grammar (parser to-state))) - do (when (let ((sym1 (aref (symbols (rule item)) (dot-position item))) - (sym2 (left-hand-side rule))) - (or (subtypep sym1 sym2) (subtypep sym2 sym1))) - (handle-item (if (functionp (right-hand-side rule)) - (make-instance 'incomplete-item - :orig-state to-state - :predicted-from item - :rule rule - :dot-position 0 - :suffix (right-hand-side rule)) - (make-instance 'complete-item - :parse-tree (right-hand-side rule))) - to-state to-state))) + (dolist (rule (gethash (aref (symbols (rule item)) (dot-position item)) + (hash (parser-grammar (parser to-state))))) + (handle-item (if (functionp (right-hand-side rule)) + (make-instance 'incomplete-item + :orig-state to-state + :predicted-from item + :rule rule + :dot-position 0 + :suffix (right-hand-side rule)) + (make-instance 'complete-item + :parse-tree (right-hand-side rule))) + to-state to-state)) (loop for parse-tree in (gethash to-state (parse-trees to-state)) do (handle-item (derive-item item parse-tree) to-state to-state)))))