D,#TD1PsT[Begin using 006 escapes];; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Base:10.; Fonts:cptfont -*-
;;
;; (C) Copyright 1982 Massachusetts Institute of Technology
;;
;; 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.
;;
;;
;; This file is part of the BOXER system.
;;

;;;; BOXER-TOP-OF-STACK-GROUP-BINDINGS

(DEFVAR *BOXER-TOP-OF-STACK-GROUP-BINDINGS*
	'((TERMINAL-IO *BOXER-PANE*)
	  (SYS:*BREAK-BINDINGS* *BOXER-BREAK-BINDINGS*)
	  (TV:KBD-INTERCEPTED-CHARACTERS *BOXER-KBD-INTERCEPTED-CHARACTERS*)
	  (BASE 10.)
	  (IBASE 10.)
	  (package (pkg-find-package "Boxer")))
  "These bindings get done /"at the top/" of every Boxer
   Stack Group. That is to say that every function which
   is written to be the top level function of a Boxer Stack
   Group should use the BOXER-TOP-OF-STACK-GROUP-BINDINGS
   special form to make sure that these bindings get done.")

(DEFVAR *BOXER-BREAK-BINDINGS*
	`((PACKAGE (PKG-FIND-PACKAGE 'BOXER))
	  (*INSIDE-LISP-BREAKPOINT-P* T)
	  . ,SYS:*BREAK-BINDINGS*)
  "SYS:*BREAK-BINDINGS* will be lambda bound to the value of
   this variable in any Boxer stack group. See the documentation
   for the *BOXER-TOP-OF-STACK-GROUP-BINDINGS* variable.")

(DEFVAR *BOXER-KBD-INTERCEPTED-CHARACTERS*
	(DELETE #\BREAK TV:KBD-STANDARD-INTERCEPTED-CHARACTERS))

;;; All the support for asynchronous characters lives here now.
;;;
;;;                                  Char-Code    Translation    Even In Break And Debugger
(DEFVAR *ASYNCHRONOUS-CHARACTERS* `((#\C-ABORT    ()             T) 
				    (#\ABORT      #\C-ABORT      NIL)
				    (#\C-M-ABORT  ()             T)
				    (#\C-BREAK    ()             T)
				    (#\C-M-BREAK  ()             T)))


(DEFMETHOD (BOXER-PANE :ASYNCHRONOUS-CHARACTER-P) (CHAR-CODE)
  (LET ((ENTRY (ASSQ CHAR-CODE *ASYNCHRONOUS-CHARACTERS*)))
    (AND ENTRY
	 (OR (CADDR ENTRY)
	     ;; This looks (and is) slow, but it only happens when an asynchronous
	     ;; character is typed so it isn't really a problem since there aren't
	     ;; so many asynchronous characters and it isn't that slow.
	     (LET ((SG (SEND (SEND SELF :PROCESS) :STACK-GROUP)))
	       (AND (NULL  (SYMEVAL-IN-STACK-GROUP '*INSIDE-LISP-BREAKPOINT-P* SG))
		    (ZEROP (SYMEVAL-IN-STACK-GROUP 'DBG:*DEBUGGER-LEVEL* SG))))))))

(DEFMETHOD (BOXER-PANE :HANDLE-ASYNCHRONOUS-CHARACTER) (CHAR-CODE)
  (TV:KBD-ASYNCHRONOUS-INTERCEPT-CHARACTER
    (OR (CADR (ASSQ CHAR-CODE *ASYNCHRONOUS-CHARACTERS*))
	CHAR-CODE) #+LMITI SELF))

;; The BOXER-TOP-OF-STACK-GROUP-BINDINGS special form binds the various
;; things that should be bound in every boxer-stack-group. All functions
;; which are the "top-level" function of a boxer-stack-group should do
;; their body inside of this special form.
(DEFMACRO BOXER-TOP-OF-STACK-GROUP-BINDINGS (&BODY BODY)
  `(PROGW *BOXER-TOP-OF-STACK-GROUP-BINDINGS*
     . ,BODY))



;; This function starts boxer in the
;; initial boxer stack group. If you look at (:METHOD EDITOR-PANE
;; :BEFORE :INIT) you will see that it presets the Boxer process
;; to run this function.
(DEFUN BOXER-PROCESS-TOP-LEVEL-FN (TERMINAL-IO)
  (BOXER-TOP-OF-STACK-GROUP-BINDINGS
    (TELL (POINT-BOX) :ENTER)
    (BOXER-COMMAND-LOOP)))

;;; We would like to make the editor somewhat reentrant for things like recursive edit levels
;;; this allows us to do things like call the evaluator inside of an INPUT box

(DEFMACRO BOXER-EDITOR-BINDINGS (&BODY BODY)
  `(PROGV '(*REGION-BEING-DEFINED*) '(NIL)
     (UNWIND-PROTECT 
	 (PROGN . ,BODY)
       (WHEN (NOT (NULL *REGION-BEING-DEFINED*)) (FLUSH-REGION *REGION-BEING-DEFINED*)))))

(DEFUN BOXER-COMMAND-LOOP ()
  (BOXER-EDITOR-BINDINGS
    (ERROR-RESTART-LOOP (SI:ABORT "Boxer top level")
      (OR (TELL TERMINAL-IO :LISTEN) (REDISPLAY))
      (HANDLE-BOXER-INPUT (TELL TERMINAL-IO :ANY-TYI)))))

(DEFUN MINI-BOXER-COMMAND-LOOP ()
  (BOXER-EDITOR-BINDINGS
    (*CATCH 'MINI-COMMAND-LOOP
      (LOOP DOING (OR (TELL TERMINAL-IO :LISTEN) (REDISPLAY))
		  (HANDLE-BOXER-INPUT (TELL TERMINAL-IO :ANY-TYI))))))

(DEFMETHOD (BOX :ENTER ) (&optional (moved-p? t))
  (SETQ *BOXER-STATIC-VARIABLES-ROOT* (if (port-box? self) ports self))
  (when (and moved-p? (eq entry-trigger-flag 'enabled))
      (tell self :do-trigger-entry-stuff)))

;  (if (not (null trigger))(boxer-funcall trigger)))

(DEFMETHOD (BOX :CODE) ()
  (OR CACHED-CODE
      (SETQ CACHED-CODE (PARSE-BOX-INTO-LAMBDA SELF))))




(DEFMETHOD (BOX :AFTER :SET-NAME) (NEW-VALUE)
  (WHEN (NAME-ROW? NEW-VALUE)
    (TELL NEW-VALUE :SET-SUPERIOR-BOX SELF)))

(DEFMETHOD (BOX :SET-NAME) (NEW-VALUE)
  (SETQ NAME NEW-VALUE))

(DEFUN GET-BOX-NAME-FOR-PRINTING (NAME)
  (COND ((STRINGP NAME) NAME)
	((NULL NAME) "Un-Named")
	((NAME-ROW? NAME)(TELL NAME :TEXT-STRING))
	(T "???")))

(DEFMETHOD (BOX :NAME) ()
  (GET-BOX-NAME-FOR-PRINTING NAME))

(defmethod (box :entry-trigger)()
  entry-trigger)

(defmethod (box :exit-trigger)()
  exit-trigger)

(defmethod (box :set-entry-trigger)(quoted-trigger-procedure)
  (setq entry-trigger quoted-trigger-procedure))

(defmethod (box :set-exit-trigger)(quoted-trigger-procedure)
  (setq exit-trigger quoted-trigger-procedure))

(defmethod (box :do-trigger-entry-stuff)()
  (let ((trigproc (or
		    (cdr (assq 'bu::entry-trigger static-variables-alist))
		      entry-trigger)))
    (when (not (null trigproc))(boxer-funcall trigproc))))

(defmethod (box :do-trigger-entry-stuff)()
  (let ((trigproc (or
;		    (boxer-funcall 'bu:first
;				    (boxer-funcall 'bu:get-named self	  
;			       		   (make-box '((trigger-entry)))))
		      entry-trigger)))
    (when (not (null trigproc))(boxer-funcall trigproc))))

(defmethod (box :do-trigger-exit-stuff)()
  (let ((trigproc (or
;		    (boxer-funcall 'bu:first
;				    (boxer-funcall 'bu:get-named self 
;						   (make-box '((trigger-exit)))))
		      exit-trigger)))
    (when (not (null trigproc))(boxer-funcall trigproc))))


(defmethod (box :enable-entry-trigger)()
  (setq entry-trigger-flag 'enabled))

(defmethod (box :disable-entry-trigger)()
  (setq entry-trigger-flag 'disabled))

(defmethod (box :enable-exit-trigger)()
  (setq exit-trigger-flag 'enabled))

(defmethod (box :disable-exit-trigger)()
  (setq exit-trigger-flag 'disabled))


(DEFMETHOD (BOX :EXIT-TRIGGER-ENABLED?) ()
  (EQ EXIT-TRIGGER-FLAG 'ENABLED))

(DEFMETHOD (BOX :ENTRY-TRIGGER-ENABLED?) ()
  (EQ ENTRY-TRIGGER-FLAG 'ENABLED))


(defboxer-function enable-entry-trigger ((list-rest box))
  (tell (car box) :enable-entry-trigger)
  :noprint)