| 252 | 252 |
(defun update-lowest-parse (term)
|
| 253 | 253 |
(declare (type term term)
|
| 254 | 254 |
(values t))
|
| 255 | |
(let ((body (term-body term)))
|
|
255 |
(let ((body (term-body term))
|
|
256 |
(assoc-applied nil))
|
| 256 | 257 |
(unless (or (term$is-variable? body) (term$is-psuedo-constant? body)
|
| 257 | 258 |
(term-is-an-error term))
|
| 258 | 259 |
;;
|
|
| 344 | 345 |
(when *term-debug*
|
| 345 | 346 |
(format t "~&[ULP] head operator was changed =======")))
|
| 346 | 347 |
;;
|
| 347 | |
#||
|
| 348 | |
(if (eq (term-head term) *bool-if*)
|
| 349 | |
(progn
|
| 350 | |
(set-if-then-else-sort term)
|
| 351 | |
;; (setq sort (term-sort term))
|
| 352 | |
)
|
| 353 | |
;; (setq sort (setf (term$sort body) (method-coarity (term$head body))))
|
| 354 | |
)
|
| 355 | |
||#
|
| 356 | |
;;
|
| 357 | 348 |
(setq head new-head)
|
| 358 | 349 |
(when (method-is-associative head)
|
| 359 | 350 |
;; &&&& the following transformation tends to put
|
|
| 375 | 366 |
;; s' s s s
|
| 376 | 367 |
;; so:
|
| 377 | 368 |
(setf (term$subterms body)
|
| 378 | |
(list (term$arg-1 son)
|
| 379 | |
(update-lowest-parse (make-term-with-sort-check-bin head (list t1 t2))))))
|
| 380 | |
; (make-applform (method-coarity head) head (list t1 t2))
|
|
369 |
(list (term$arg-1 son)
|
|
370 |
(update-lowest-parse (make-term-with-sort-check-bin head (list t1 t2)))))
|
|
371 |
(setq assoc-applied t))
|
|
372 |
|
| 381 | 373 |
;; would only like to do the following if the
|
| 382 | 374 |
;; sort really decreases
|
| 383 | 375 |
(when (and (not (or (term$is-variable? (setq son (term-body
|
|
| 387 | 379 |
(sort= (term-sort (setq t1 (term$arg-1 body)))
|
| 388 | 380 |
(term-sort (setq t2 (term$arg-1 son))))
|
| 389 | 381 |
(sort< (term-sort t1) (term-sort (term$arg-2 son)) sort-order))
|
| 390 | |
(when *term-debug*
|
| 391 | |
(format t "~&[ULP] ASSOCIATIVITY 2"))
|
|
382 |
|
| 392 | 383 |
;; we are in the following configuration
|
| 393 | 384 |
;; fs' -> fs'
|
| 394 | 385 |
;; s fs' fs s'
|
|
| 398 | 389 |
(list (update-lowest-parse
|
| 399 | 390 |
;(make-applform (method-coarity head) head (list t1 t2))
|
| 400 | 391 |
(make-term-with-sort-check-bin head (list t1 t2)))
|
| 401 | |
(term$arg-2 son)))))
|
|
392 |
(term$arg-2 son)))
|
|
393 |
(when *term-debug*
|
|
394 |
(format t "~&[ULP] ASSOCIATIVITY 2~%=> ")
|
|
395 |
(term-print-with-sort term))
|
|
396 |
;; we mark
|
|
397 |
(setf assoc-applied t)))
|
| 402 | 398 |
|
| 403 | 399 |
;; necesary to have true lowest parse
|
| 404 | 400 |
|
|
| 408 | 404 |
(alt-op (lowest-method head
|
| 409 | 405 |
(list (term-sort t2) (term-sort t1)))))
|
| 410 | 406 |
(when (not (eq alt-op head))
|
| 411 | |
(term-replace term ;(make-applform (method-coarity alt-op) alt-op (list t2 t1))
|
|
407 |
(term-replace term
|
| 412 | 408 |
(make-term-with-sort-check-bin alt-op (list t2 t1))))))
|
| 413 | 409 |
(mark-term-as-lowest-parsed term)
|
| 414 | |
term)))))
|
|
410 |
(values term assoc-applied))))))
|
| 415 | 411 |
|
| 416 | 412 |
#||
|
| 417 | 413 |
(defun update-lowest-parse (term)
|
|
| 458 | 454 |
;;; (setf (term$sort body) (method-coarity (term$head body)))
|
| 459 | 455 |
(setf (term-sort term) (method-coarity (term-head term)))
|
| 460 | 456 |
|
| 461 | |
;; ;;;;; FOR NOW;;;;;;;;;;;;;
|
| 462 | |
;; (return-from update-lowest-parse term)
|
| 463 | 457 |
;; extensions for associativity: if s and s' are sorts s.t. s < s' then
|
| 464 | 458 |
(when (method-is-associative head)
|
| 465 | 459 |
;; &&&& the following transformation tends to put
|