1;-*-* cold-load:t; Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10. 1-*-


;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;*
;1;; Copyright (C) 1986-1989 Texas Instruments Incorporated. All rights reserved.


;; Conditionals

;; IF permits multiple ELSE clauses despite the definition given in the CLM (Common Lisp Manual)*

(DEFUN IF (&QUOTE predicate then &REST elses)

  1"SYNTAX: (IF predicate form1 {form}*)
  If predicate evaluates non-nil, then IF returns the results of evaluating
  form1. Otherwise treats {form}* as a PROGN."*
  
  (IF (*EVAL predicate) (*EVAL then) (EVAL-BODY-AS-PROGN elses)))

1;;  AND, OR and COND are supposed to be implemented as macros according to the
;;  Common Lisp Manual. However these must execute fast in the interpreter.*

(DEFUN AND (&QUOTE &REST expressions)

  1"SYNTAX: (AND {form}*)
  Evaluates the forms left-to-right until one returns NIL or the forms have
  been exhausted. Returns all values of the last form evaluated or t if there
  are no forms."*
  
  (IF (NULL expressions) t
      (DO ((l expressions (CDR l)))
	  ((NULL (CDR l))
	   (*EVAL (CAR l)))
	(OR (*EVAL (CAR l))
	    (RETURN nil)))))


(DEFUN OR (&QUOTE &REST expressions)

  1"SYNTAX: (OR {form}*)
  Evaluates the forms left-to-right until one returns something non-NIL. 
  Returns all values of the last form evaluated or NIL if there are no
  forms."*
  
  (IF (NULL expressions) nil
      (DO ((l expressions (CDR l))
	   (val))
	  ((NULL (CDR l))
	   (*EVAL (CAR l)))
	(AND (SETQ val (*EVAL (CAR l)))
	     (RETURN val)))))


(DEFUN COND (&QUOTE &REST clauses)

  1"Looks for the first CLAUSE whose predicate is true, and executes that clause.
Each element of the body of a COND is called a CLAUSE.
The first element of each clause is a PREDICATE-EXPRESSION.
This is evaluated to see whether to execute the clause.
If the predicate's value is non-NIL, all the remaining elements of the clause
are executed, as in a PROGN, and the value(s) of the last one are returned by COND.
If the clause contains only one element, the predicate, then
the predicate's value is returned if non-NIL.
In this case, unless it is the last clause, the predicate is not
being called tail-recursively and so only its first value is returned.

If no clause's predicate evaluates non-NIL, the COND returns NIL."*

  (DO ((clauses clauses (CDR clauses))
       clause
       predval)
      ((NULL clauses) nil)
    (COND ((ATOM (SETQ clause (CAR clauses)))
	   (FERROR nil "The atom ~S is not a valid COND clause." clause))
	  ((AND (NULL (CDR clauses)) (NULL (CDR clause)))
	   1;; If this is the last clause, then treat its predicate as part of*
	1   ;; the body instead of as the predicate*.1However, return only the one value*
	1  * (RETURN (VALUES (EVAL-BODY-AS-PROGN clause))))
	  ((SETQ predval (*EVAL (CAR clause)))
	   (RETURN (IF (CDR clause) (EVAL-BODY-AS-PROGN (CDR clause)) predval))))))


(DEFUN DEAD-CLAUSES-WARNING (cond-clauses function-name)
  "Given a list of COND-clauses, warn if any but the last starts with T.
FUNCTION-NAME (usually a macro name) is used in the warning.
The warning is made iff we are now accumulating warnings for an object."

  (DO ((clauses cond-clauses (CDR clauses)))
      ((NULL (CDR clauses)))
    (AND (EQ (CAAR clauses) T)
	 OBJECT-WARNINGS-OBJECT-NAME
	 (RETURN
	   (COMPILER:WARN 'DEAD-CODE ':IMPLAUSIBLE
			  "Unreachable clauses following otherwise-clause in ~S." FUNCTION-NAME)))))


;;PAD 3/11/87  Added xor for the next edition of Steele.
;;AB for PHD 6/19/87. Took out extraneous Eval. SPR 5626.
(DEFUN xor (&rest args)
  "Takes any number of arguments and returns T if an odd number of its arguments are non-NIL, 
otherwise returns NIL."
  (LET ((flag nil))
    (DOLIST (form args flag)
      (WHEN form
	(SETF flag (not flag))))))