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 FUNCALL (fn &REST args)
  1"applies the function object <fct> to the arguments <args>. See also APPLY"*

  (APPLY fn args))


(DEFUN APPLY (fct arg &REST args)
  1"Apply the function <fct> to some arguments <arg> and <args>. <fct> must not be a macro
nor a special form. The last of the arguments must be a list. For example,
the following invocations are correct and compute the same result:
 (apply #'+ '(1 2 3)) , (apply #'+ 1 '(2 3)) , (apply #'+ 1 2 '(3)) and (apply #'+ 1 2 3 ())."*
  
  (IF (NULL args)
      (APPLY fct arg)
      (LET ((number-of-args (1+ (LENGTH args))))
	(%ASSURE-PDL-ROOM number-of-args)
	(%PUSH arg)
	(DO ((argl args (CDR argl)))1 *             1 ;; push all arguments save the last onto the stack*
	    ((NULL (CDR argl))1                   ;; the last arg should be a list-- spread it on the stack*
	     (%PUSH (CAR argl))
	     (%CALL fct number-of-args :lexpr t))
	  (%PUSH (CAR argl))))))


1;; NOTE: APPLY and LEXPR-FUNCALL are not the same function.*


(DEFUN ZLC:LEXPR-FUNCALL (fct &REST args)
  1"Apply <fct> to the <args>, except that the last element of <args> is a list of args.
Thus, (2ZLC:LEXPR-FUNCALL* 'FOO 'X '(Y Z)) and (2ZLC:LEXPR-FUNCALL* 'FOO '(X Y Z)) is equivalent to (FOO 'X 'Y 'Z).
When there are no <args>, the car of <fct> is applied to the cdr of <fct>."*
  
  (IF (NULL args)
      (APPLY (CAR fct) (CDR fct))
      (LET ((number-of-args (LENGTH args)))
	(%ASSURE-PDL-ROOM number-of-args)
	(DO ((argl args (CDR argl)))1 *             1 ;; push all arguments save the last onto the stack*
	    ((NULL (CDR argl))1                   ;; the last arg should be a list-- spread it on the stack*
	     (%PUSH (CAR argl))
	     (%CALL fct number-of-args :lexpr t))
	  (%PUSH (CAR argl))))
      ))

;;Old definition.
;;;(defun multiple-value-call (function &quote &rest forms)
;;;  1"Call Function but use all values returned by each of FORMS as arguments to Function"*
;;;  (apply function (mapcan #'(lambda (form) (multiple-value-list (*eval form)))
;;;			  forms)))


;;2/25/87 PHD for DNG Put back the faster definition
;;5/2/89 DNG - added doc string.
(eval-when (load)
(defun multiple-value-call (&functional function &quote &rest forms)
  "Evaluates the FORMS, saving all of their values, and then calls FUNCTION with
all those values as arguments."
  (let ((nvalues 0))
    (do ((rest forms (cdr rest)))
	((null rest))
      (compiler2:%PUSH-VALUES-AND-COUNT (*eval (car rest)))
      (setq nvalues (+ (%pop) nvalues)) )
    (%call function nvalues)))
 )


;(CALL function arg-desc-1 arg-data-1 arg-desc-2 arg-data-2 ...)
;The first argument is a function to call.
;The remaining arguments are in pairs, consisting of
;a descriptor arg and a data arg.
;The descriptor arg says what to do with the data arg.
;The descriptor arg value should be either a keyword or
;a list of keywords, the allowed keywords being :SPREAD and :OPTIONAL.
;:SPREAD means that the data argument is a list of arguments
;rather than a single argument.
;:OPTIONAL means that the data argument can be ignored if
;the function being called doesn't ask for it.
;After the first :OPTIONAL, all args supplied are considered optional.


;(CALL function arg-desc-1 arg-data-1 arg-desc-2 arg-data-2 ...)



(DEFUN CALL (FN &REST ALTERNATES)
  1"the first argument is a function to call.
The remaining arguments are in pairs, consisting of a descriptor arg and a data arg.
The descriptor arg says what to do with the data arg.
The descriptor arg value should be either a keyword or a list of keywords or NIL.
NIL means that the data argument is to be treated as a single argument to the
 function.
The allowed keywords are :SPREAD and :OPTIONAL.
:SPREAD means that the data argument is a list of arguments
 rather than a single argument.
:OPTIONAL means that the data argument can be ignored if
 the function being called doesn't ask for it.
 After the first :OPTIONAL, additional args supplied are considered optional.
If you don't need the special :OPTIONAL and :SPREAD processing, use FUNCALL instead."*
   (declare (arglist function arg-desc-1 arg-data-1 arg-desc-2 arg-data-2 etc))
   (multiple-value-bind (minimum-args req+opts rest-arg)
       (args-desc fn)
     (declare (ignore minimum-args))
     (loop 
       with max-args = (if rest-arg CALL-ARGUMENTS-LIMIT req+opts)
       with args-pushed = 0
       for (desc data) on alternates by #'cddr
       as optional-flag = nil and spread-flag = nil
       doing (cond ((listp desc)
		    (loop for keyword in desc
			  doing (case keyword
				      (:spread   (setq spread-flag   t))
				      (:optional (setq optional-flag t))
				      (otherwise (ferror nil "Invalid CALL keyword ~S." desc)))))
		   (t 
		    (case desc
			  (:spread   (setq spread-flag   t))
			  (:optional (setq optional-flag t))
			  (otherwise ( ferror nil "Invalid CALL keyword ~S." desc)))))
       when (and optional-flag
		 (<= max-args 0))
       do (return (%call fn args-pushed))
       doing (cond (spread-flag
		    (loop for arg in data
			  until (and optional-flag (<= max-args 0))
			  doing (%assure-pdl-room 1)
			  (%push arg)
			  (decf max-args)
			  (incf args-pushed)))
		   (:else
		    (%assure-pdl-room 1)
		    (%push data)
		    (decf max-args)
		    (incf args-pushed)))
       finally (return (%call fn args-pushed)))))