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


;;;                           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
;;;
;;; Copyright (C) 1986-1989 Texas Instruments Incorporated.  All rights reserved.*

(DEFUN SETQ (&QUOTE &REST symbols-and-values)
  1"SYNTAX:(SETQ var1 exp1 var2 exp2 ... varN expN)
  Symbols-and-values represents a list of alternating symbol-value pairs of
  the form VAR EXP which are processed left-to-right by assigning the result
  of evaluating EXP to VAR. This destroys the current binding of VAR.  The
  value of the last EXP is returned."*
  
  (DO ((symbols-and-values symbols-and-values (cddr symbols-and-values))
       (var)
       (val))
      ((ATOM symbols-and-values) val)		; return the last computed value
    (SETQ var (CAR symbols-and-values))		; the variable to be SETQ'd
    (UNLESS (VARIABLE-P var)
      (IF (SYMBOLP var)
	  (FERROR nil "attempted to SETQ the ~a ~s"
		  (IF (KEYWORDP var) "KEYWORD" "CONSTANT") var)
	  (FERROR nil "a non-symbol ~s is the target of a SETQ" var)))
    (UNLESS (CDR symbols-and-values)
      (FERROR nil "no value supplied for ~s  in SETQ" var))
    (SETQ val (*EVAL (CADR symbols-and-values)))
    (IF (ZETALISP-ON-P)
	(SET var val)
	(INTERPRETER-SET var val))))

(DEFUN PSETQ-PROG1IFY (X)
  (COND ((NULL X) NIL)
	((NULL (CDDR X)) (CONS 'SETQ X))
	(T `(SETQ ,(CAR X) (PROG1 ,(CADR X) ,(PSETQ-PROG1IFY (CDDR X)))))))