;;; -*- Mode:LISP; Package:COMPILER; Readtable:CL; Base:10; Lowercase:T -*-

;;;Nested IF optimizer.
;;;
;;;Advantages:
;;;
;;; 1) Optimize both CL and ZL defs uniformly
;;; 2) Optimizes nested IFs into subsequent COND clauses; i.e.,
;;;     A. Turns      (IF <COND> <then> (IF <then2> ...)) 
;;;        Into       (COND (<COND> <then>) (<then2> ...))
;;;     B. Turns      (IF <COND1> (IF <COND2> <then2> <else2>) <else1>)
;;;        Into       (COND ((not <COND1>) <else1>) (<COND2> <then2>) (t <else2>))


(defun fix-nested-ifs (form)
  (cons 'cond (t-if-or-nil form)))

(defun fix-oldstyle-if (form)
  `(cond (,(cadr form) ,(caddr form)) (t ,@(cdddr form))))

(defun t-if-or-nil (form)
  (cond
    ((not (memq (car-safe form)			;Not a nested IF
		'(zl:if lisp:if)))		; (not on the list of IFs),
     (ncons (list t form)))			; so end of COND.
    ((> (length form) 4)			;ELSE clause has multiple forms;
     (and (eq (car form) 'lisp:if)		; for CommonLISP, 
	  (warn 'improper-common-lisp :obsolete	; issue warning,
	    "~S used with ~D extra argument~:P."
	    'lisp:if (- (length form) 4)))
     (cdr (fix-oldstyle-if form)))		; ...then treat like PROGN.
    ((memq (car-safe (third form)) '(zl:if lisp:if))
     (t-if-or-nil `(if (not ,(second form)) ,(fourth form) ,(third form))))
    (t
     `((,(second form) ,(third form))		;Collect this COND clause,
       ,@(t-if-or-nil (fourth form))))))	; and look for more.

;;;Set optimizers on both IF variants:
(defoptimizer fix-cli-if cli:if (form) (fix-nested-ifs form))
(defoptimizer fix-zli-if if     (form) (fix-nested-ifs form))

#|
TEST CASES -- be sure to test in both ZL and CL mode!

(defun flit (x l)
  (if (null l) nil
    (if (< (car l) 0)
	(flit x (cdr l))
      (if x (print 'test-atomic-case)
	(if (cdr x) (print 'test-incompatible-case) (print 'another-incompatible-case) (print 'yet-another))
	(print 'this-only-gets-signalled-in-commonlisp-mode)
	(cons (car l)
	      (flit x (cdr l)))))))

(defun simp (x)
  (if x (print 'hi) (print 'bye))
  (print (if x 'hi 'bye 'solong))
  (if x 'ok 'really 'bye-anyway))

(progn 'turn-off-if-optimizers
       (setf (get 'lisp:if 'optimizers) nil)
       (setf (get 'zl:if 'optimizers) nil))
|#