;;; -*- 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

;;; Copyright (C) 1986-1989 Texas Instruments Incorporated. All rights reserved.*

(PROCLAIM '(INLINE ZETALISP-ON-P COMMON-LISP-ON-P))

1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; WITH-MULTIPLE-VALUE-BINDING-LIST & ZL-WITH-MULTIPLE-VALUE-BINDING-LIST
;;
;;   variable binding for MULTIPLE-VALUE-BIND
;;
;; Given separate lists VARLIST, VALLIST and SPECIALS, representing respectively
;; variables to be bound, the values and the variables declared special, this
;; creates a binding frame and adds it to the lexical environment for use in
;; evaluating BODY. If there are fewer symbols than values, discard remaining
;; values. If there are fewer values than symbols, bind remaining symbols to nil.*

(eval-when (compile)
  (DEFMACRO WITH-MULTIPLE-VALUE-BINDING-LIST ((varlist vallist specials) &BODY body)
    `(LET ((bindlist (%MAKE-STACK-LIST (* 2 (LENGTH ,varlist)))))
       (DO ((nextbinding ,varlist (CDR nextbinding))
	    (nextstackpos bindlist (CDDR nextstackpos))
	    (nextvalue   ,vallist )
	    (symbol)
	    (symbol-loc)
	    (value))
	   ((ATOM nextbinding)
	    (WITH-STACK-LIST* (*INTERPRETER-ENVIRONMENT* bindlist *INTERPRETER-ENVIRONMENT*)
	      . ,body))
	 (SETQ symbol (CAR nextbinding))
	 (SETQ value 
	       (IF (ATOM nextvalue) nil 
		   (PROG1 (CAR nextvalue) (SETQ nextvalue (CDR nextvalue)))))
	 (IF (VARIABLE-P symbol)
	     (SETQ symbol-loc (VALUE-CELL-LOCATION symbol))
	     (BINDING-ERROR symbol))
	 (COND
	   ((SPECIAL-VAR-P symbol ,specials)
	    (BIND symbol-loc value)
	    (SETF (CAR nextstackpos) symbol-loc)
;; TGC	    (%P-STORE-DATA-TYPE (LOCF (CADR nextstackpos)) DTP-EXTERNAL-VALUE-CELL-POINTER)
;;	    (%P-STORE-POINTER (LOCF (CADR nextstackpos)) symbol-loc)
	    (%p-store-data-type-and-pointer
	      (LOCF (CADR nextstackpos)) DTP-EXTERNAL-VALUE-CELL-POINTER symbol-loc))
	   (t
	    (SETF (CAR nextstackpos) symbol-loc)
	    (SETF (CADR nextstackpos) value))))))
  
  (defmacro zl-bind-variables-spread ((varlist value-list-exp) &body body)
    `(prog (vars-left vals-left)
	   ;; Now loop over the varlist, computing and pushing initial values.
	   (setq vars-left ,varlist)
	   (setq vals-left ,value-list-exp)
	short-nextvar
	   (unless vars-left
	     (return (progn . ,body)))
	   (if (car vars-left )  ;; ignore NIL
	       (bind (value-cell-location (car vars-left)) (car vals-left)))
	   (pop vars-left)
	   (pop vals-left)
	   (go short-nextvar)))
  )

1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; VALUES-LIST, VALUES, NTH-VALUE, MULTIPLE-VALUE-LIST & MULTIPLE-VALUE-PROG1
;;   In the implementation below, it may appear that values-list defines a
;;   non-terminating recursive function...alas it does not. The defun merely
;;   defines a special form for use by the interpreter while the body of the
;;   defun references the compiler's version of the same function.*

(DEFUN VALUES-LIST (list)
  1"SYNTAX: (VALUES-LIST list)
  Returns all the elements of LIST as values. Note
  (VALUES-LIST (list a b c)) = (VALUES a b c)"*
  
  (VALUES-LIST list))

(DEFUN VALUES (&REST values)
  1"Syntax: (VALUES {form}*)
  Returns the value of each form - one per form."*
  
  (VALUES-LIST values))

(DEFUN NTH-VALUE (value-number &QUOTE exp)
 1"SYNTAX:(NTH value-number multiple-value-returning-form)
 Evaluates the form and returns the VALUE-NUMBER'th  (0-based) value
 discarding the rest."*

  (NTH value-number (MULTIPLE-VALUE-LIST (*EVAL exp))))

(DEFUN MULTIPLE-VALUE-LIST (&QUOTE exp)
  1"Evaluate the expression EXP and return a list of the values it returns."*
  (MULTIPLE-VALUE-LIST (*EVAL exp)))

(DEFUN MULTIPLE-VALUE-PROG1 (&QUOTE &REST forms)
  1"Evaluates VALUE-FORM followed by the FORMs, then returns ALL the values of VALUE-FORM."*
  (MULTIPLE-VALUE-PROG1 (*EVAL (FIRST forms))
			(MAPC #'(LAMBDA (f) (*EVAL f)) (REST forms))))

(DEFUN MULTIPLE-VALUE-SETQ (&QUOTE var-list exp)
  1"Evaluate EXP, collecting multiple values, and set the variables in VAR-LIST to them.
Returns the first value of EXP."*
  (let ((val-list (multiple-value-list (*EVAL exp))))
    (do ((vars var-list (cdr vars))
	 (vals val-list (cdr vals)))
	((null vars))
      (when (car vars)
	(if (ZETALISP-ON-P)
	    (set (car vars) (car vals))
	    (interpreter-set (car vars) (car vals)))))
    (car val-list)))

(DEFF zlc:multiple-value 'multiple-value-setq)

;;PHD 2/11/87 Fixed body, extract-special-declarations expect body to be a real body.
(DEFUN MULTIPLE-VALUE-BIND (&QUOTE &REST body)
 1"Bind the variables in VAR-LIST to the multiple values returned from VALUES-FORM.
While the variables are bound evaluate the BODY-FORMS.  Declarations may be included
prior to the BODY-FORMS."*
  (declare (arglist var-list values-form &rest body-forms))

  (LET ((varlist (CAR body))
	(vallist  (MULTIPLE-VALUE-LIST (*EVAL (CADR body)))))
    (IF (ZETALISP-ON-P)
	(ZL-BIND-VARIABLES-SPREAD (varlist vallist)
	  (EVAL-BODY-AS-PROGN (CDDR body)))
	(LET* ((body (cddr body))
	       (specials (EXTRACT-SPECIAL-DECLARATIONS)))
	  (WITH-MULTIPLE-VALUE-BINDING-LIST (varlist vallist specials)
					    (EVAL-BODY-AS-PROGN body))))))