Codebase list cafeobj / 0363327
Fix: parsing overloading constants. tswd 8 years ago
2 changed file(s) with 38 addition(s) and 49 deletion(s). Raw diff Collapse all Expand all
+6
-3
chaos/primitives/boperator.lisp less more
10201020 (declare (type method meth)
10211021 (type hash-table info)
10221022 (values (or null t)))
1023 (when *on-operator-debug*
1024 (format t "~%[method-is-assosiative]:")
1025 (print-chaos-object meth))
10231026 (theory-contains-associativity (method-theory meth info)))
10241027
10251028 ;;; METHOD-IS-IDENTITY
14451448 (dolist (m (cdr list-meth) res)
14461449 (if (method<= res m)
14471450 (setq res m)
1448 (unless (method-is-of-same-operator res m)
1451 (unless (method-is-in-same-component res m)
14491452 (return-from choose-most-general-op nil))))))
14501453
14511454 ;;; choose-lowest-op : ops => or null method
14521455 ;;; NOTE: assumes *current-sort-order* and *current-opinfo-table* are bound to
14531456 ;;; properly.
1454 ;;;
1457 ;;; This is used for selecting a term from multiple parse result.
14551458 (defun choose-lowest-op (list-meth)
14561459 (unless (cdr list-meth)
14571460 (return-from choose-lowest-op (car list-meth)))
14651468 (if (method<= m res)
14661469 (setq res m)
14671470 ;; return immediately iff two methods are not comparable
1468 (unless (method-is-of-same-operator res m)
1471 (unless (method-is-in-same-component res m)
14691472 (return-from choose-lowest-op nil))))
14701473 (when *on-operator-debug*
14711474 (format t "~%--> ")
+32
-46
chaos/term-parser/parse-top.lisp less more
116116 (t (setf result (make-bconst-term *syntax-err-sort*
117117 (if res
118118 res
119 preterm)))
120 ))
119 preterm)))))
121120 ;;
122121 (setq *parse-raw-parse* result)
123122 (when (term-ill-defined result)
124123 (with-output-simple-msg ()
125124 (format t "~&[Error] no successful parse")
126 (print-next)
127 ;; (print-term-tree result t)
128 ;; (term-print result)
129 ))
130 (parse-convert result module))))
131 ))
125 (print-next)))
126 (parse-convert result module))))))
132127
133128 (defun select-parse (module final &optional print-warning)
134129 (declare (type module module)
179174 (nth (1- choise) final)))
180175 (progn
181176 (parse-show-diff final)
182 (make-bconst-term *syntax-err-sort* "ambiguous term")
183 ))
184 ))
177 (make-bconst-term *syntax-err-sort* "ambiguous term")))))
185178
186179 (defun pre-choose-final-sub (module final)
187180 (declare (type module module)
265258 result)
266259 res)
267260 (setq result res))
268
269261 (t (setq gen-op (choose-most-general-op mslist))
270262 ;; then select most general one
271263 (when gen-op
272264 (push (find-if #'(lambda (x) (method= gen-op (term-head x))) result)
273265 res)
274266 (setq result res)))))))
275 (pre-choose-final-sub module result)))
267 (if result
268 (pre-choose-final-sub module result)
269 (pre-choose-final-sub module final))))
276270
277271 ;;; NOT USED NOW.
278272 (defun parser-diagnose (module preterm sort)
535529 (defun parser-find-rule-pair (module lhslst rhslst)
536530 (declare (type module module)
537531 (type list lhslst rhslst))
538 (let ((*current-module* module))
532 (with-in-module (module)
539533 (let ((so (module-sort-order module))
540534 (ok nil)
541 (retr nil)
542 (ill nil))
535 (retr nil))
536 ;; foreach lhs:lhslst {
537 ;; foreach rhs:rhslst {
543538 (dolist (lhs lhslst)
544 (let ((sl (term-sort lhs)))
545 (dolist (rhs rhslst)
546 (let ((sr (term-sort rhs)))
547 (if (term-ill-defined lhs)
548 (push (list lhs rhs) ill)
549 (if (term-head-is-error lhs)
550 (if (is-in-same-connected-component sl sr so)
551 (push (list lhs rhs) retr)
552 ;; else, completely bad, unacceptable
553 ())
554 ;; lhs is proper term
555 (if (sort<= sr sl so)
556 (if (term-ill-defined rhs)
557 (push (list lhs rhs) ill)
558 (push (list lhs rhs) ok))
559 (if (is-in-same-connected-component sl sr so)
560 (if (term-ill-defined rhs)
561 (push (list lhs rhs) ill)
562 (push (list lhs rhs) retr))
563 ;; lhs and rhs is not in same compo.
564 ()
565 )
566 ))))
567 )))
568 (if ok
569 ok
570 (if retr
571 retr
572 nil))
573 )))
539 (block cont-lhs
540 (when *on-axiom-debug*
541 (format t "~%lhs: ")
542 (term-print-with-sort lhs))
543 (when (term-ill-defined lhs)
544 (return-from cont-lhs)) ; skip it and continue
545 (let ((sl (term-sort lhs)))
546 (dolist (rhs rhslst)
547 (block cont-rhs
548 (when *on-axiom-debug*
549 (format t "~&rhs: ")
550 (term-print-with-sort rhs))
551 (when (term-ill-defined rhs)
552 (return-from cont-rhs)) ; continue it and continue
553 (let ((sr (term-sort rhs)))
554 (if (sort<= sr sl so)
555 (push (list lhs rhs) ok)
556 (when (is-in-same-connected-component sl sr so)
557 (push (list lhs rhs) retr)))))))))
558 ;;
559 (or ok retr nil))))
574560
575561 ;;; used in modexp-compute-op-mapping
576562 ;;;