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


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


(DEFUN SYMEVAL-IN-CLOSURE (CLOSURE PTR)
  1"Return the value which the symbol or value cell locative PTR has in CLOSURE.
More precisely, the value which is visible within CLOSURE is returned.
If CLOSURE does not contain a binding for it, the current value is returned."*
  (CHECK-ARG CLOSURE (CLOSUREP CLOSURE) "a closure")
  (CHECK-ARG PTR (COND ((SYMBOLP PTR) (SETQ PTR (VALUE-CELL-LOCATION PTR)))
		       ((= (%DATA-TYPE PTR) DTP-LOCATIVE)))
	         "a symbol or a locative")
  (DO ((L (CDR (CONVERT-CLOSURE-TO-LIST CLOSURE)) (CDDR L)))
      ((NULL L)
       (CAR PTR))
    (WHEN (EQ (CAR L) PTR)
	 (RETURN (CAADR L)))))

(DEFUN BOUNDP-IN-CLOSURE (CLOSURE PTR &AUX PTR1)
  1"T if the symbol or value cell locative PTR is BOUNDP within CLOSURE.
More precisely, the binding which is visible within CLOSURE is tested.
If CLOSURE does not contain a binding for it, the current binding is tested."*
  (CHECK-ARG CLOSURE (CLOSUREP CLOSURE) "a closure")
  (CHECK-ARG PTR (OR (SYMBOLP PTR) (LOCATIVEP PTR)) "a symbol or a locative")
  (SETQ PTR1 (IF (SYMBOLP PTR) (LOCF (SYMBOL-VALUE PTR)) PTR))
  (DO ((L (CDR (CONVERT-CLOSURE-TO-LIST CLOSURE)) (CDDR L)))
      ((NULL L)
       (LOCATION-BOUNDP PTR1))
    (WHEN (EQ (CAR L) PTR1)
	 (RETURN (LOCATION-BOUNDP (CADR L))))))

(DEFUN MAKUNBOUND-IN-CLOSURE (CLOSURE PTR &AUX PTR1)
  "Make the symbol or value cell locative PTR unbound in CLOSURE.
More precisely, the binding which is visible within CLOSURE is made unbound.
If CLOSURE does not contain a binding for it, the current binding is made unbound."
  (CHECK-ARG CLOSURE (CLOSUREP CLOSURE) "a closure")
  (CHECK-ARG PTR (OR (SYMBOLP PTR) (LOCATIVEP PTR)) "a symbol or a locative")
  (SETQ PTR1 (IF (SYMBOLP PTR) (LOCF (SYMBOL-VALUE PTR)) PTR))
  (DO ((L (CDR (CONVERT-CLOSURE-TO-LIST CLOSURE)) (CDDR L)))
      ((NULL L)
       (IF (SYMBOLP PTR) (MAKUNBOUND PTR)
	 (LOCATION-MAKUNBOUND PTR)))
    (WHEN (EQ (CAR L) PTR1)
	   (RETURN (LOCATION-MAKUNBOUND (CADR L)))))
  NIL)

(DEFUN LOCATE-IN-CLOSURE (CLOSURE PTR)
  1"Return the location of the value which the symbol or value cell locative PTR has in CLOSURE.
More precisely, the location of the binding visible within CLOSURE is returned.
If CLOSURE does not contain a binding for it, the value cell
locative itself, or the symbol's value cell location, is returned."*
  (CHECK-ARG CLOSURE (CLOSUREP CLOSURE) "a closure")
  (CHECK-ARG PTR (COND ((SYMBOLP PTR) (SETQ PTR (VALUE-CELL-LOCATION PTR)))
		       ((= (%DATA-TYPE PTR) DTP-LOCATIVE)))
	         "a symbol or a locative")
  (DO ((L (CDR (CONVERT-CLOSURE-TO-LIST CLOSURE)) (CDDR L)))
      ((NULL L)
       PTR)
    (AND (EQ (CAR L) PTR)
	 (RETURN (CADR L)))))

(DEFUN SET-IN-CLOSURE (CLOSURE PTR VAL)
  1"Set the value which the symbol or value cell locative PTR has in CLOSURE to VAL.
More precisely, the binding which is visible within CLOSURE is set.
If CLOSURE does not contain a binding for it, the current binding is set."*
  (CHECK-ARG CLOSURE (CLOSUREP CLOSURE) "a closure")
  (CHECK-ARG PTR (COND ((SYMBOLP PTR) (SETQ PTR (VALUE-CELL-LOCATION PTR)))
		       ((= (%DATA-TYPE PTR) DTP-LOCATIVE))) "a symbol or a locative")
  (DO ((L (CDR (CONVERT-CLOSURE-TO-LIST CLOSURE)) (CDDR L)))
      ((NULL L)
       (RPLACA PTR VAL))
    (WHEN (EQ (CAR L) PTR)
	   (RETURN (RPLACA (CADR L) VAL))))
  VAL)


(DEFUN CLOSURE-VARIABLES (CLOSURE)
  1"Return a list of variables closed over by CLOSURE."*
  (CHECK-ARG CLOSURE (CLOSUREP CLOSURE) "a closure")
  (IF (AND (CDR (CONVERT-CLOSURE-TO-LIST CLOSURE))
	   (NULL (CDDR (CONVERT-CLOSURE-TO-LIST CLOSURE))))
      '(LEXICAL-ENVIRONMENT)
    (DO ((L (CDR (CONVERT-CLOSURE-TO-LIST CLOSURE)) (CDDR L))
	 (ANS NIL (CONS (%MAKE-POINTER-OFFSET DTP-SYMBOL (CAR L) -1) ANS)))
	((NULL L) ANS))))

(DEFUN CLOSURE-ALIST (CLOSURE)
  1"Return an alist of variables closed over by CLOSURE vs their values they have inside it.
If one of the variables is unbound in the closure,
the corresponding cdr in the alist will also be a DTP-NULL.
Storing into the alist cdr's does not affect the values in the closure."*
  (CHECK-ARG CLOSURE (CLOSUREP CLOSURE) "a closure")
  (IF (AND (CDR (CONVERT-CLOSURE-TO-LIST CLOSURE))
	   (NULL (CDDR (CONVERT-CLOSURE-TO-LIST CLOSURE))))
      (LIST (CONS 'LEXICAL-ENVIRONMENT
		  (CADR (CONVERT-CLOSURE-TO-LIST CLOSURE))))
    (DO ((L (CDR (CONVERT-CLOSURE-TO-LIST CLOSURE)) (CDDR L))
	 (ANS))
	((NULL L) ANS)
      (SETQ ANS (CONS (CONS (%MAKE-POINTER-OFFSET DTP-SYMBOL (CAR L) -1)
			    NIL)
		      ANS))     ;; Copy (CAADR L) into (CDAR ANS).
      (%BLT-TYPED (CADR L) (CDR-LOCATION-FORCE (CAR ANS)) 1 1) )))

(DEFUN CLOSURE-FUNCTION (CLOSURE)
  1"Return the function closed over in CLOSURE."*
  (CHECK-ARG CLOSURE (CLOSUREP CLOSURE) "a closure")
  (CAR (CONVERT-CLOSURE-TO-LIST CLOSURE)))

(DEFUN CLOSURE-BINDINGS (CLOSURE)
  1"Return the bindings of CLOSURE, shared with CLOSURE.
This is suitable for use in SYS:%USING-BINDING-INSTANCES."*
  (CHECK-ARG CLOSURE CLOSUREP "a closure")
  (CDR (CONVERT-CLOSURE-TO-LIST CLOSURE)))

(DEFF CLOSURE-COPY 'COPY-CLOSURE)   ;Old name

(DEFUN COPY-CLOSURE (CLOSURE &AUX CLOSURE1)
  1"Return a new closure with the same function, variables and initial values as CLOSURE.
However, the new and old closures do not share the same external value cells."*
  (CHECK-ARG CLOSURE (CLOSUREP CLOSURE) "a closure")
  (SETQ CLOSURE1 (CONVERT-CLOSURE-TO-LIST CLOSURE))
  (IF (AND (CDR (CONVERT-CLOSURE-TO-LIST CLOSURE))
	   (NULL (CDDR (CONVERT-CLOSURE-TO-LIST CLOSURE))))
      (%MAKE-POINTER DTP-CLOSURE (COPY-LIST CLOSURE1))
    (LET ((ANS (MAKE-LIST (LENGTH CLOSURE1))))
      (RPLACA ANS (CAR CLOSURE1))		;CLOSE OVER SAME FCTN
      (DO ((L (CDR CLOSURE1) (CDDR L))
	   (N (CDR ANS) (CDDR N)))
	  ((NULL L) (%MAKE-POINTER (%DATA-TYPE CLOSURE) ANS))
	(RPLACA N (CAR L))			;SAME INTERNAL VALUE CELL
	(LET ((NEW-EXVC (MAKE-LIST 1)))
	  (IF (NOT (LOCATION-BOUNDP (CADR L)))
	      (LOCATION-MAKUNBOUND NEW-EXVC)
	    (RPLACA NEW-EXVC (CAR (CADR L))))
	  (RPLACA (CDR N) NEW-EXVC))))))