;; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Base:10.; Fonts:CPTFONT -*-
;;
;; (C) Copyright 1983 MIT
;;
;; Permission to use, copy, modify, distribute, and sell this software
;; and its documentation for any purpose is hereby granted without fee,
;; provided that the above copyright notice appear in all copies and that
;; both that copyright notice and this permission notice appear in
;; supporting documentation, and that the name of M.I.T. not be used in
;; advertising or publicity pertaining to distribution of the software
;; without specific, written prior permission.  M.I.T. makes no
;; representations about the suitability of this software for any
;; purpose.  It is provided "as is" without express or implied warranty.
;;
;;
;; Deep Binding in Boxer.

;;Dynamic Boxer variables exist in an alist.  You get the value of a
;;variable by calling the lookup function on it.
;;

;;If the variable is not found in the alist, then the static variables of the boxes in
;;the lexical scope of the outermost box being executed are searched.  This searching
;;happens by asking the DOIT'ed box to look up the variable in its static
;;alist, and failing finding it there to ask the box it is inside of to do the same,
;;all the way to the toplevel box.

;;If this search fails, then the lookup function checks the global lispm value cell
;;of the symbol.  This keeps it from having to search a long ``tail'' of primitive
;;values.

;;FUNCTION CALLING.
;;When a function is called, the funcalling mechanism boxer-binds the input variables of the
;;box being called to be the argument values.  It does this by lisp-binding the big alist
;;to be a cons of those variable names and values on the front of
;;the big alist.  This lisp binding goes away when the funcall primitive returns.
;;
;;In addition to the input variables, then alist of static variables for the current box
;;is copied and added to the big alist temporary binding.  It is copied since in our
;;copy-and-execute model, modifications to the static bindings of a box made while the
;;box is being are not retained when the box returns.
;;***this is not yet implemented***
;;
;; TELL
;;TELL binds *BOXER-BINDING-ALIST-ROOT* to NIL (to hide any dynamic bindings)
;;and binds *BOXER-BINDING-ALIST-ROOT* to box being told.

(deff boxer-error 'ferror)

(defvar *currently-executing-box* nil
 "BOXER-FUNCALL binds this to the box it is funcalling.")

(DEFVAR *BOXER-STATIC-VARIABLES-ROOT* NIL
  "The DOIT key binds the box whose region is being run to be this box.")

(DEFMACRO WITH-STATIC-ROOT-BOUND (NEW-ROOT &BODY BODY)
  `(LET ((*BOXER-STATIC-VARIABLES-ROOT* ,NEW-ROOT))
     . ,BODY))

(DEFVAR *BOXER-DYNAMIC-VARIABLES-ALIST* NIL)

(DEFMACRO WITH-DYNAMIC-VALUES-BOUND (NEW-FRAME &BODY BODY)
  `(LET ((*BOXER-DYNAMIC-VARIABLES-ALIST*
	   (ADJOIN-FRAME ,NEW-FRAME *BOXER-DYNAMIC-VARIABLES-ALIST*)))
     . ,BODY))

(DEFMACRO WITH-NEW-DYNAMIC-VALUES (NEW-FRAME &BODY BODY)
  `(LET ((*BOXER-DYNAMIC-VARIABLES-ALIST* (ADJOIN-FRAME ,NEW-FRAME NIL)))
     . ,BODY))

(defmacro boxer-let* (bindings &body body)
  `(let ((*boxer-binding-alist-root*
	   (nconc (mapcar #'(lambda (pair)
			      (cons (car pair)
				    (eval (cadr pair))))
			  ',bindings)
		  *boxer-binding-alist-root*)))
     .,body))

;;Handling the dynamic environment

;;; this need to flatten out any exporting boxes (SLOW !!!)
;;; The whole exporting scheme needs to be re-implemented for speed
;;; and here's an example why....
(DEFUN GET-LOCAL-ENV (BOX)
  (COND ((BOX? BOX)
	 (LET* ((BINDINGS (TELL BOX :GET-STATIC-VARIABLES-ALIST))
		(EXPORTS (MAPCAR #'CDR
				 (SUBSET #'(LAMBDA (X) (EQ (CAR X) *EXPORTING-BOX-MARKER*))
					 BINDINGS)))
		(parsed-bindings (with-collection
				   (dolist (b bindings)
				     (unless (eq (car b) *exporting-box-marker*)
				       (collect b))))))
	   (LEXPR-FUNCALL #'APPEND parsed-bindings
			  (MAP-TELL EXPORTS :GET-STATIC-VARIABLES-ALIST))))
	((NUMBERP BOX) NIL)
	(T (EVBOX-BINDINGS BOX))))

;;; This is doing EXPLICIT copying of local variables because we are only copying the args and
;;; NOT the function itself whenever we funcall
(DEFSUBST MAKE-FRAME (BOX &OPTIONAL ARGS)
  (NCONC (NCONS (CONS :FRAME-HEADER BOX))
	 (PAIRLIS				;side effects are safe because of 
	   (GET-ARG-NAMES BOX)			;PAIRLIS
	   ARGS)
	 (LET ((*EVALUATOR-COPYING-FUNCTION* #'SHALLOW-COPY-FOR-ARGLIST))
	   (MAPCAR #'(LAMBDA (X) (CONS (CAR X) (COPY-FOR-EVAL (CDR X))))
		   (GET-LOCAL-ENV BOX)))))

(DEFSUBST ADJOIN-FRAME (FRAME ENV)
  (APPEND FRAME ENV))

;;Variable lookup function

;; note that box can be an EVbox
(defun lookup-static-variable (variable box)
  (cond ((box? box) (tell box :lookup-static-variable-check-superiors variable))
	((evbox? box) (assq variable (evbox-bindings box)))
	(t (ferror "Don't know how to look up the variable, ~S, in ~S" variable box))))

(DEFUN BOXER-SYMEVAL (VARIABLE)
  (LET ((ENTRY (ASSQ VARIABLE *BOXER-DYNAMIC-VARIABLES-ALIST*)))
    (COND ((NOT (NULL ENTRY)) (CDR ENTRY))
	  ((SETQ ENTRY (lookup-static-variable VARIABLE *BOXER-STATIC-VARIABLES-ROOT*))
	   (CDR ENTRY))
	  ((BOUNDP VARIABLE)		    ;global primitive?
	   (SYMEVAL VARIABLE))		    ;we cache them to avoid a long tail in the alist.
	  (T (BOXER-ERROR "The variable ~A is not bound." VARIABLE)))))

(DEFUN BOXER-BOUNDP (VARIABLE)
  (or (assq variable *BOXER-DYNAMIC-VARIABLES-ALIST*)
      (LOOKUP-STATIC-VARIABLE variable *BOXER-STATIC-VARIABLES-ROOT*)
      (boundp variable)))			;global primitive?

;; local lookup function
;; This takes an alist and looks up the variable.  If there are EXPORTS into the alist, then 
;; we recurse through the alists of the exports as well
;; GET-NAMED uses this
;; Note that this is doing a depth first search of the exports (where we might actually want 
;; a breadth first search
(DEFUN LOOKUP-LOCAL-VARIABLE (VAR ALIST)
  (LET ((EXPORTS (SUBSET #'(LAMBDA (X) (EQ (CAR X) *EXPORTING-BOX-MARKER*)) ALIST))
	(THING (CDR (ASSQ VAR ALIST))))
    (IF (NOT (NULL THING)) THING
	(DOLIST (EXPORT EXPORTS)
	  (LET ((VALUE (LOOKUP-LOCAL-VARIABLE VAR (GET-LOCAL-ENV (CDR EXPORT)))))
	    (WHEN (NOT (NULL VALUE)) (RETURN VALUE)))))))

;;; KEEP this around for the parser
;Variable setting function with searching.  Errors if there is no such variable.
;Copied from lookup function.
;This is a low-level function.  Note that sometimes variable "setting"
;is implemented as box-alteration.
;(defun boxer-set (variable value)
;  (let ((entry (assq variable *BOXER-DYNAMIC-VARIABLES-ALIST*)))
;    (cond ((access-pair? variable)
;	   (let ((*BOXER-STATIC-VARIABLES-ROOT* (boxer-eval (access-pair-superbox variable)))
;		 (*BOXER-DYNAMIC-VARIABLES-ALIST* NIL))
;	     (boxer-set (caar (get-pre-box-rows (access-pair-subbox variable))) value)))
;	  ((not (null entry)) (setf (cdr entry) value))
;	  (t (setq entry (tell *BOXER-STATIC-VARIABLES-ROOT*
;			       :LOOKUP-STATIC-VARIABLE-CHECK-SUPERIORS
;			       variable)) 
;	     (if (not (null entry))
;		 (setf (cdr entry) value)
;		 (boxer-error "The variable ~S is not bound." variable))))))

;;; Weird stuff.
;;; Since there's no consistency about EVBOX objects we'll just add this here.

(defun add-static-variable-to-evbox (evbox variable value)
  (if (eq variable *exporting-box-marker*)
      (add-static-variable-to-evbox-internal evbox variable value)
      (let ((entry (assq variable (evbox-bindings evbox))))
	(cond ((null entry)
	       (add-static-variable-to-evbox-internal evbox variable value))
	      (t (format t "Warning, replacing the old value of ~A" variable)
		 (setf (cdr entry) value))))))

(defun add-static-variable-to-evbox-internal (evbox variable value)
  (set-evbox-bindings evbox (cons (cons variable value)
				  (evbox-bindings evbox))))
;;;Lower level methods.

;;;Adds the variable/value pair to the current box's static variable alist.
;;;Needs to be smart about altering the alist -- or maybe re-calculating it or something?
;;;This implementation is broken since you won't be able to access the variable after
;;;you use it.

(DEFMETHOD (BOX :SET-STATIC-VARIABLES-ALIST) (NEW-ALIST)
  ;; the file system uses this one.
  (SETQ STATIC-VARIABLES-ALIST NEW-ALIST))

(DEFMETHOD (BOX :GET-STATIC-VARIABLES-ALIST) ()
  ;; the file system uses this one too.
  STATIC-VARIABLES-ALIST)

(defun boxer-add-static-variable (variable value)
  (tell (or *CURRENTLY-EXECUTING-BOX* *BOXER-STATIC-VARIABLES-ROOT*)
	:ADD-STATIC-VARIABLE-PAIR variable value))

(defmethod (box :add-static-variable-pair) (variable value)
  (let ((entry (assq variable static-variables-alist)))
    (WHEN (AND (NOT-NULL (TELL SELF :LOOKUP-STATIC-VARIABLE-IN-BOX-ONLY VARIABLE))
	       (NEQ (CDR (TELL SELF :LOOKUP-STATIC-VARIABLE-IN-BOX-ONLY VARIABLE)) VALUE)
	       (NEQ VARIABLE *EXPORTING-BOX-MARKER*))
      ;; The name is already defined in the current box to be something else
      (FORMAT T "Warning, replacing the old value of ~A "VARIABLE))
    (WHEN (SPRITE-BOX? VALUE)
      ;; This is not the correct solution since you might want to keep
      ;; some named sprites private to the graphics box.  This should
      ;; cause the average user to win most of the time though
      (TELL SELF :EXPORT-VARIABLE VARIABLE))
    (COND ((AND (NEQ VARIABLE *EXPORTING-BOX-MARKER*) (not (null entry)))
	   (setf (cdr entry) value))
	  ((AND (EQ VARIABLE *EXPORTING-BOX-MARKER*) (EQ VALUE (CDR ENTRY))))
	  ;;try and cut down on multiple copies of the same box being exported
	  (T (push (cons variable value) static-variables-alist)))))

(DEFMETHOD (BOX :REMOVE-ALL-STATIC-BINDINGS) (VALUE)
  "Removes all the variables which may be bound to VALUE. "
  (LOOP WITH NEW-EXPORTS = NIL
	FOR PAIR IN STATIC-VARIABLES-ALIST
	UNLESS (EQ (CDR PAIR) VALUE)
	COLLECT PAIR INTO NEW-ALIST
	WHEN (AND (LISTP EXPORTS) (EQ (CDR PAIR) VALUE))
	DO (SETQ NEW-EXPORTS (DELQ (CAR PAIR) EXPORTS))
	FINALLY (SETQ STATIC-VARIABLES-ALIST NEW-ALIST)
	        (unless (eq exports  *EXPORT-ALL-VARIABLES-MARKER*)
		  (setq EXPORTS NEW-EXPORTS))))

(DEFMETHOD (BOX :REMOVE-STATIC-VARIABLE) (VARIABLE)
  "Removes only the single variable binding from the Box's environment. "
  (SETQ STATIC-VARIABLES-ALIST (DELQ (ASSQ VARIABLE STATIC-VARIABLES-ALIST)
				     STATIC-VARIABLES-ALIST))
  (WHEN (AND (NOT-NULL EXPORTS) (NEQ EXPORTS *EXPORT-ALL-VARIABLES-MARKER*))
    (SETQ EXPORTS (DELQ VARIABLE EXPORTS))))

(DEFMETHOD (BOX :SET-EXPORTS) (NEW-EXPORTS)
  (SETQ EXPORTS NEW-EXPORTS))

(DEFMETHOD (BOX :GET-EXPORTS) ()
  (IF (EQ EXPORTS *EXPORT-ALL-VARIABLES-MARKER*)
      (MAPCAR #'CAR STATIC-VARIABLES-ALIST)
      EXPORTS))

(DEFMETHOD (BOX :EXPORT-ALL-VARIABLES) ()
  (WHEN (NULL EXPORTS)
    (TELL (TELL SELF :SUPERIOR-BOX) :ADD-STATIC-VARIABLE-PAIR *EXPORTING-BOX-MARKER* SELF))
    (SETQ EXPORTS *EXPORT-ALL-VARIABLES-MARKER*))

(DEFMETHOD (BOX :EXPORT-VARIABLE) (VARIABLE)
  (LET ((VALUE (TELL SELF :LOOKUP-STATIC-VARIABLE-IN-BOX-ONLY VARIABLE)))
    (UNLESS (NULL VALUE)
      (WHEN (NULL EXPORTS)
	(TELL (TELL SELF :SUPERIOR-BOX) :ADD-STATIC-VARIABLE-PAIR
	      *EXPORTING-BOX-MARKER* SELF))
      (UNLESS (EQ EXPORTS *EXPORT-ALL-VARIABLES-MARKER*)
	(PUSH VARIABLE EXPORTS)))))

(DEFMETHOD (BOX :GET-EXPORTING-BOXES) ()
  "Get a list of all the other boxes which export their variable bindings to this one. "
  (MAPCAR #'CDR (SUBSET #'(LAMBDA (X) (EQ (CAR X) *EXPORTING-BOX-MARKER*))
			STATIC-VARIABLES-ALIST)))

(DEFMETHOD (BOX :LOOKUP-STATIC-VARIABLE-IN-EXPORTS) (VARIABLE)
  (LET ((EXPORTING-BOXES (TELL SELF :GET-EXPORTING-BOXES))
	(EXPORTING-P (OR (EQ EXPORTS *EXPORT-ALL-VARIABLES-MARKER* ) (MEMQ VARIABLE EXPORTS)))
	(VALUE (ASSQ VARIABLE STATIC-VARIABLES-ALIST)))
    (COND ((AND VALUE EXPORTING-P) VALUE)
	  ((AND ;(OR (EQ EXPORTS *EXPORT-ALL-VARIABLES-MARKER* ) (MEMQ VARIABLE EXPORTS))
	        ;allow exported variables to automatically be visible anywhere up the chain
	        ;of exporting boxes. 
		(NOT-NULL EXPORTING-BOXES))
	   (DOLIST (BOX EXPORTING-BOXES)
	     (LET ((BINDING-PAIR (TELL BOX :LOOKUP-STATIC-VARIABLE-IN-EXPORTS VARIABLE)))
	       (WHEN (NOT-NULL BINDING-PAIR)
		 (RETURN BINDING-PAIR))))))))

(DEFMETHOD (BOX :LOOKUP-STATIC-VARIABLE-IN-BOX-ONLY) (VARIABLE)
  (LET ((VALUE (ASSQ VARIABLE STATIC-VARIABLES-ALIST))
	(EXPORTING-BOXES (TELL SELF :GET-EXPORTING-BOXES)))
    (COND (VALUE VALUE)
	  ((NOT-NULL EXPORTING-BOXES)
	   (DOLIST (BOX EXPORTING-BOXES)
	     (LET ((BINDING-PAIR (TELL BOX :LOOKUP-STATIC-VARIABLE-IN-EXPORTS VARIABLE)))
	       (WHEN (NOT-NULL BINDING-PAIR)
		 (RETURN BINDING-PAIR))))))))

(DEFMETHOD (BOX :SUPERIOR-BOX-FOR-BINDINGS) ()
  (TELL SELF :SUPERIOR-BOX))

(DEFMETHOD (PORT-BOX :SUPERIOR-BOX-FOR-BINDINGS) ()
  (TELL-CHECK-NIL PORTS :SUPERIOR-BOX))

(defmethod (box :lookup-static-variable-check-superiors) (variable)
  (let ((value (assq variable static-variables-alist))
	(EXPORTING-BOXES (TELL SELF :GET-EXPORTING-BOXES))
	(superior))
    (cond (value value)
	  ;; if we found it, return it
	  ((NOT-NULL EXPORTING-BOXES)
	   ;; first, look in the boxes which export their variables to this box
	   (let ((result 
		   (DOLIST (BOX EXPORTING-BOXES)
		     (LET ((BINDING-PAIR (TELL BOX
					       :LOOKUP-STATIC-VARIABLE-IN-EXPORTS VARIABLE)))
		       (WHEN (NOT-NULL BINDING-PAIR)
			 (RETURN BINDING-PAIR))))))
	     (if result result (tell (tell self :superior-box-FOR-BINDINGS)
				     :lookup-static-variable-check-superiors variable))))
	  ((setq superior (tell self :superior-box-FOR-BINDINGS))
	   (tell superior :lookup-static-variable-check-superiors variable))
	  (t nil))))

(DEFMETHOD (BOX :LOCAL-LIBRARY) ()
  (OR LOCAL-LIBRARY
      (SETQ LOCAL-LIBRARY
	    (MAKE-INITIALIZED-BOX ':TYPE ':LL-BOX
				  ':EXPORTS *EXPORT-ALL-VARIABLES-MARKER*))))

;; the file system uses this one
(DEFMETHOD (BOX :SET-LOCAL-LIBRARY) (NEW-LL)
  (SETQ LOCAL-LIBRARY NEW-LL))

(DEFMETHOD (BOX :REMOVE-LOCAL-LIBRARY) ()
  (WHEN (NOT-NULL LOCAL-LIBRARY)
    (TELL SELF :REMOVE-ALL-STATIC-BINDINGS LOCAL-LIBRARY)
    (SETQ LOCAL-LIBRARY NIL)))