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

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

1;; FLET, MACROLET & LABELS
;;
;; The macro WITH-FUNCTION-BINDING-LIST is used to create binding frames for
;; *INTERPRETER-FUNCTION-ENVIRONMENT*.*


;;PHD 3/2/87 early evaluation of caller to generate a better code.
;;PHD 3/2/87 Replaced list and list* by stack list primitives.
;;DNG 11/16/88 Add support for GENERIC-FLET.
;; 03/16/89 clm - Integrated changes for CLOS into Kernel.
(eval-when (compile)
  (DEFMACRO WITH-FUNCTION-BINDING-LIST ((fctlist caller) &BODY body)
    `(LET ((bindlist (%MAKE-STACK-LIST (* 2 (LENGTH ,fctlist)))))
       (DO ((nextbinding ,fctlist (CDR nextbinding))
	    (nextstackpos bindlist (CDDR nextstackpos))
	    (fct)
	    (fctsymbol))
	   ((ATOM nextbinding)
	    (WITH-STACK-LIST* (*INTERPRETER-FUNCTION-ENVIRONMENT*
				bindlist *INTERPRETER-FUNCTION-ENVIRONMENT*)
	      . ,body))
	 (SETQ fct (CAR nextbinding) fctsymbol (CAR fct))
	 (COND
	   ((VARIABLE-P fctsymbol)
	    (SETF (CAR nextstackpos) (LOCF (SYMBOL-FUNCTION fctsymbol)))
	    ;;Warning, dont-optimize is required because %make-explicit-stack-list modifies the 
            ;;stack. prevent the compiler from interleaving stack primitives with stack-list 
            ;;primitives.
	    (dont-optimize
	    (let ((value ,(COND
		     ((EQ caller 'FLET)
			`(funcall  'FUNCTION  (%make-explicit-stack-list* 'cli:lambda (cdr fct))))
		     ((EQ caller 'LABELS)
		      `(let ((block-form (%make-explicit-stack-list*  'block fctsymbol (CDDR fct))))
			(%make-explicit-stack-list 'lambda (CADR fct) block-form)))
		     ((EQ caller 'MACROLET)
		      `(%make-explicit-stack-list*  'macro (MAKE-EXPANDER-FUNCTION fct)))
		     ((EQ caller 'TICLOS:GENERIC-FLET)
		      `(*eval (%make-explicit-stack-list* 'TICLOS:GENERIC-FUNCTION (cdr fct))))))
		  (place (CDR nextstackpos)))
	      (rplaca place  value))))
	   (t (BINDING-ERROR fctsymbol))))))
  )

(eval-when (compile)
  (defmacro zl-parallel-function-binding-list ((varlist ignore macroflag) &body body)
    `(prog (vars-left)
	   ;; Now bind all the prog-variables.
	   ;; DO cannot be used, since the scope of the BINDs would be wrong.
	   (setq vars-left ,varlist)
	bindloop
	   (cond (vars-left
		  ;; For each symbol, push 2 words on stack:
		  ;; value cell location and new value.
		  (%push (function-cell-location (caar vars-left)))
		  (%push (if ,macroflag
			     `(macro . ,(make-expander-function (car vars-left)))
			     `(lambda . ,(cdar vars-left))))
		  (pop vars-left)
		  (go bindloop)))
	   
	   (setq vars-left ,varlist)
	bindloop1
	   (cond (vars-left
		  ;; Pop off next symbol and value, and bind them.
		  (bind (%pop) (%pop))
		  ;; Step down VARS-LEFT just so we pop as many pairs as we pushed.
		  (pop vars-left)
		  (go bindloop1)))
	   (return (progn . ,body))))
  )


;; 03/16/89 clm - Integrated into Kernel for CLOS.
(DEFUN TICLOS:GENERIC-FLET (&QUOTE function-list &REST body)
  "Syntax: (GENERIC-FLET ({function-spec lambda-list {option}*}*) {form}*)
Like FLET but the local functions are generic.  
The options are the same as for DEFGENERIC, but the most useful here is 
\(:METHOD {qualifier}* lambda-list . body)"
  ;; 11/16/88 DNG - Original.
   
   (LET ((ignore (EXTRACT-SPECIAL-DECLARATIONS)))
      (WITH-FUNCTION-BINDING-LIST (function-list TICLOS:GENERIC-FLET)
         (EVAL-BODY-AS-PROGN body))))

;; 03/16/89 clm - Integrated into Kernel for CLOS.
(DEFUN TICLOS:GENERIC-LABELS (&QUOTE function-list &REST body)
  "Syntax: (GENERIC-LABELS ({function-spec lambda-list {option}*}*) {form}*)
Like LABELS but the local functions are generic.  
The options are the same as for DEFGENERIC, but the most useful here is 
\(:METHOD {qualifier}* lambda-list . body)"
  ;; 11/16/88 DNG - Original.
   
   (LET ((ignore (EXTRACT-SPECIAL-DECLARATIONS)))
      (WITH-FUNCTION-BINDING-LIST (function-list LABELS)
         (DO ((frametail (CAR *INTERPRETER-FUNCTION-ENVIRONMENT*) (CDDR frametail)))
	     ((ATOM frametail))
	  (SETF (CADR frametail)
	       (*eval (%make-explicit-stack-list* 'TICLOS:GENERIC-FUNCTION
						       (cdr (CADR frametail))))))
         (EVAL-BODY-AS-PROGN body))))




(DEFUN FLET (&QUOTE function-list &REST body)
 1"SYNTAX: (FLET ( (fct1 (...) body) ... (fctN (...) body)) {form}*)
 The first argument is a list of function definitions followed by a
 sequence of forms to be evaluated as a PROGN with the function
 definitions in effect. Each of the functions is closed in the
 environment OUTSIDE the scope of the FLET implying they cannot
 refer to one another and ,in particular, they cannot refer to
 themselves. See LABELS."*

  (IF (ZETALISP-ON-P)
      (zl-parallel-function-binding-list (function-list nil nil)
	(EVAL-BODY-AS-PROGN body))
      (LET ((ignore (EXTRACT-SPECIAL-DECLARATIONS)))
	(WITH-FUNCTION-BINDING-LIST (function-list FLET)
	  (EVAL-BODY-AS-PROGN body)))))


;;PHD called directly function instead of (*eval `(function ...
(DEFUN LABELS (&QUOTE function-list &REST body)
 1"SYNTAX: (LABELS ((fct1 (...) body) ... (fctN (...) body)) {form}*)
 The first argument is a list of function definitions followed by a
 sequence of forms to be evaluated as a PROGN with the function
 definitions in effect. Each of the functions is closed in the
 same environment WITHIN the LABELS so that the functions may refer
 to each other and themselves. This is used to define mutually recursive
 functions."*

  (IF (ZETALISP-ON-P)
      (zl-parallel-function-binding-list (function-list nil nil)
	(EVAL-BODY-AS-PROGN body))
      (LET ((ignore (EXTRACT-SPECIAL-DECLARATIONS)))
	(WITH-FUNCTION-BINDING-LIST (function-list LABELS)
	  (DO ((frametail (CAR *INTERPRETER-FUNCTION-ENVIRONMENT*) (CDDR frametail)))
	      ((ATOM frametail))
	    (SETF (CADR frametail)
		  (funcall 'function (CADR frametail))))
	  (EVAL-BODY-AS-PROGN body)))))

;;PHD 3/24/87 Change the order of evaluation of extract-special-declaration.
;;It needs to macroexpand using the macrolet macro-bindings.
(DEFUN MACROLET (&QUOTE macro-list &REST body)
 1"SYNTAX: (MACROLET ((mac1 (...) body) ... (macN (...) body)) {form}*)
 The first argument is a list of macro definitions followed by a sequence
 of forms containing references to those definitions."*

  (IF (ZETALISP-ON-P)
      (ZL-PARALLEL-FUNCTION-BINDING-LIST (macro-list t t)
	(EVAL-BODY-AS-PROGN body))
	(WITH-FUNCTION-BINDING-LIST (macro-list MACROLET)
				    (EVAL-BODY-AS-PROGN (LET ((ignore (EXTRACT-SPECIAL-DECLARATIONS)))
							  body)))))

;;; DRH commentary on FUNCTION:
;;;  1) when <function> is a MICROCODE-FUNCTION, a COMPILED-FUNCTION or a LEXICAL-CLOSURE, there is
;;;  no reason to form a closure since the lexical variables accessible through the interpreter
;;;  are not accessible from the bodies of functions of these types.
;;;  2) when <function> is a CLOSURE, a case could be made for again producing a CLOSURE. Our reason for
;;;  not doing this invoves an understanding of how CLOSUREs are handled by the microcode machinery.
;;;  When the latter sees a closure, it places the environment closed over into effect [this consists
;;;  of special variables whose value cells are set with an EVCP pointing to the data within the closure
;;;  structure.] and then calls the function object in a tail recursive manner. Now suppose we had a
;;;  a closure whose function object was another closure. When the closure is called, the outermost environment
;;;  is placed into effect and the function object called. But since this is a closure too, the microcode will
;;;  place its environment into effect, thereby overriding the previous one, and call the function object. The
;;;  fault lies with the basic design of closures. This is something that can be fixed in Rel4.
;;;  3) when <function> is a CONS and its CAR is NAMED-LAMBDA or LAMBDA , FUNCTION produces a CLOSURE whose
;;;  function object is a CLOSURE-NAMED-LAMBDA. This serves to distinguish CLOSUREs from NAMED-LAMBDAs , produced
;;;  by DEFUN at top level , and anonymous lambdas written by the user. This distinction is necessary in APPLY-LAMBDA
;;;  which is called by the microcode when the function object is  a list. If the list begins with something other
;;;  than expected, VALIDATE-FUNCTION-SPEC is called and the function object it denotes, if any, is returned.

;;  4/12/89 DNG - Added use of *INTERPRETER-EXTRA-ENVIRONMENT* .
(DEFUN FUNCTION (&QUOTE function)
  1"Quotes FUNCTION for use as a function.
If FUNCTION is a symbol, its function definition in the current environment is returned.
If FUNCTION is a list (presumably starting with LAMBDA),the compiler will compile it 
and the interpreter will make it into a closure closing over the lexical environment
in effect."*

  (TYPECASE function
    (symbol
     (IF (ZETALISP-ON-P)
	 (SYMBOL-FUNCTION function)
	 (INTERPRETER-FSYMEVAL  function)))
    (cons
     (LET ((header (CAR function)))
       (COND ((MEMBER header '(ZLC:NAMED-LAMBDA ZLC:NAMED-SUBST ZLC:LAMBDA SUBST NAMED-SUBST) :TEST #'EQ) function)
	     ((MEMBER header '(NAMED-LAMBDA LAMBDA) :TEST #'EQ) 
	      (IF (OR *interpreter-environment* *interpreter-function-environment*)
		  (LET ((*interpreter-environment* 
			  (COPY-LIST-INTO-HEAP *interpreter-environment*))
			(*interpreter-function-environment* 
			  (COPY-LIST-INTO-HEAP *interpreter-function-environment*)))
		    (CLOSURE (if (null *interpreter-extra-environment*)
				 '(*interpreter-environment* *interpreter-function-environment*)
			       '(*interpreter-environment* *interpreter-function-environment*
							   *interpreter-extra-environment*))
			     (IF (EQ header 'lambda)
				 (LIST* 'closure-named-lambda nil (CDR function))
				 (CONS 'closure-named-lambda (CDR function)))))
		  function))
	     ((EQ header 'MACRO)
	      (LET((def (FUNCALL #'FUNCTION (CDR function))))
		(IF (EQ def (CDR function))
		    function
		  (CONS 'MACRO def))))
	     ((VALIDATE-FUNCTION-SPEC function) (FDEFINITION function))
	     (t (FERROR nil "~S is not a function or the name of a function" function)))))
    ((OR compiled-function microcode-function closure lexical-closure) function)
    (T (FERROR nil "~S is not a function or the name of a function" function))))


;;PHD 12/30/86 Fixed copy-list-into-heap, save off (car env) and (cdr env) to locals
;;PHD 2/3/87   Fixed a bug (car newenv) was not updated when car-v was not a stack-list.
;;             instead of writing them into memory that will trigger the microcode copy 
;;             DTP-Stack-List to heap.
;;RJF 7/30/87  Fix problem where EVCP was being written on top of a body-forwarded word
;;             because structure forwarding not followed for ENV.  [SPR 5956]
(DEFUN COPY-LIST-INTO-HEAP (env &AUX (newenv env))
  ;; This procedure is used to copy the interpreter's lexical environment off of the stack.
  ;; The copy operation is low level and involves use of EVCPs to forward references to the heap.
  (WHEN (CONSP env)
    (WHEN (STACK-LIST-P env)
      (let ((car-v (car env))
	    (cdr-v (cdr env))) 
	(SETQ NEWENV (CONS nil nil))
        (WHEN (= dtp-body-forward (%p-data-type env))
	  (SETQ env (follow-structure-forwarding env)))	;rjf
	(%P-DPB DTP-EXTERNAL-VALUE-CELL-POINTER %%q-data-type (1+ (%pointer env)))  ; drh-fix
	(%P-DPB (1+ (%pointer newenv)) %%q-pointer (1+ (%pointer env)))	; drh-fix
	(%P-DPB DTP-EXTERNAL-VALUE-CELL-POINTER %%q-data-type env)
	(%P-DPB newenv %%q-pointer env)
	(LET* ((frame car-v)
	       (newframe frame))
	  (WHEN (STACK-LIST-P frame)
	    (SETQ newframe (MAKE-LIST (LENGTH frame)))
	    ;; Copy each word of the old frame to the new, then
	    ;; forward each word of the old frame to the new.
	    ;; Uses %BLT to copy in case what's there is a DTP-EXTERNAL-VALUE-CELL-POINTER.
	    (DO ((l newframe (cdr l))
		 (m frame (cdr m)))
		((null l))
	      (%BLT-TYPED m l 1 0)
	      (%p-store-data-type-and-pointer m DTP-EXTERNAL-VALUE-CELL-POINTER l)))
	    (SETF (CAR newenv) newframe))
	(WHEN cdr-v
	  (LET ((newrest (COPY-LIST-INTO-HEAP cdr-v)))
	    (SETF (CDR newenv) newrest))))))
    newenv)