1;;; -*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:8; Cold-Load:T -*-

;;;                           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) 1984-1989 Texas Instruments Incorporated.  All rights reserved.*

;;; This is the version of BREAK that runs in the cold load until the
;;; UCLized version is loaded.

;Note that BREAK binds RUBOUT-HANDLER to NIL so that a new level of catch
;will be established.  Before returning it restores the old rubout handler's buffer.
;;; Cold Load version of BREAK (UCL redefines it)
(DEFUN BREAK (&OPTIONAL FORMAT-STRING &REST ARGS
	      &AUX SAVED-BUFFER SAVED-BUFFER-POSITION)
  "Read-eval-print loop for use as subroutine.  Arguments are passed to FORMAT.
Many variables are rebound, as specified in SI:*BREAK-BINDINGS*."
  (DECLARE (ARGLIST &OPTIONAL FORMAT-STRING &REST ARGS))
  (SETQ FORMAT-STRING
	(IF (OR (AND (SYMBOLP FORMAT-STRING)
		     (BOUNDP FORMAT-STRING))
		(AND (CONSP FORMAT-STRING)
		     (EQ (CAR FORMAT-STRING) 'QUOTE)
		     (SYMBOLP (CADR FORMAT-STRING))
		     (NULL (CDDR FORMAT-STRING))
		     (SETQ FORMAT-STRING (CADR FORMAT-STRING))))
	    (STRING FORMAT-STRING)
	  (*EVAL FORMAT-STRING)))
  (UNLESS (OR (EQUAL FORMAT-STRING "")
	      (MEMBER (AREF FORMAT-STRING (1- (LENGTH FORMAT-STRING))) '(#\. #\? #\!) :TEST #'EQ))
    (SETQ FORMAT-STRING (STRING-APPEND FORMAT-STRING #\.)))
  (PROGW *BREAK-BINDINGS*
    ;; Deal with keyboard multiplexing in a way similar to the error-handler.
    ;; If we break in the scheduler, set CURRENT-PROCESS to NIL.
    ;; If this is not the scheduler process, make sure it has a run reason
    ;; in case we broke in the middle of code manipulating process data.
    ;; If INHIBIT-SCHEDULING-FLAG is set, turn it off and print a warning.
    (COND ((EQ %CURRENT-STACK-GROUP SCHEDULER-STACK-GROUP)
	   (SETQ CURRENT-PROCESS NIL)))
    (AND (NOT (NULL CURRENT-PROCESS))
	 (NULL (FUNCALL CURRENT-PROCESS :RUN-REASONS))
	 (FUNCALL CURRENT-PROCESS :RUN-REASON 'BREAK))
    (COND (INHIBIT-SCHEDULING-FLAG
	   (FORMAT T "~%---> Turning off INHIBIT-SCHEDULING-FLAG, you may lose. <---~%")
	   (SETQ INHIBIT-SCHEDULING-FLAG NIL)))
    (AND (MEMBER :SAVE-RUBOUT-HANDLER-BUFFER
		 (FUNCALL OLD-STANDARD-INPUT :WHICH-OPERATIONS) :TEST #'EQ)
	 (SETF (VALUES SAVED-BUFFER SAVED-BUFFER-POSITION)
	       (FUNCALL OLD-STANDARD-INPUT :SAVE-RUBOUT-HANDLER-BUFFER)))
    (FORMAT T "~&;Breakpoint ~?  ~:@C to continue, ~:@C to quit.~%"
	    FORMAT-STRING ARGS #\RESUME #\ABORT)
    (LET* ((VALUE
	     (LOOP
	       (TERPRI)
	       LOOK-FOR-SPECIAL-KEYS
	       (LET ((CHAR (FUNCALL *STANDARD-INPUT* :TYI)))
		 ;; Intercept characters even if otherwise disabled in program
		 ;; broken out of.  Also treat c-Z like ABORT for convenience
		 ;; and for compatibility with the error handler.
		 (AND (= CHAR #\C-Z) (SETQ CHAR #\ABORT))
		 (COND ((AND (BOUNDP 'TV:KBD-STANDARD-INTERCEPTED-CHARACTERS)
			     (ASSOC CHAR TV:KBD-STANDARD-INTERCEPTED-CHARACTERS :TEST #'EQ))
			(FUNCALL (CADR (ASSOC CHAR TV:KBD-STANDARD-INTERCEPTED-CHARACTERS :TEST #'EQ))
				 CHAR))
		       ((= CHAR #\RESUME)
			(FUNCALL *STANDARD-OUTPUT* :STRING-OUT "[Resume]
")
			(RETURN NIL))
		       (T (FUNCALL *STANDARD-INPUT* :UNTYI CHAR))))
	       ;;  It is important to stack-cons the T, rather than heap-consing it, so we don't
	       ;;  end up copying out the stack-consed eh:*condition-resume-handlers*, which is
	       ;;  slow in any case and can possibly damage eq-ness.  - pf, Sept 19, 1986
	       (CONDITION-RESUME T
		 (LET ((THROW-FLAG T))
		   (CATCH-ERROR-RESTART ((SYS:ABORT ERROR)
					 "Return to BREAK ~?"
					 FORMAT-STRING ARGS)
		     (MULTIPLE-VALUE-BIND (TEM1 TEM)
			 (FUNCALL *STANDARD-INPUT* :RUBOUT-HANDLER '((:FULL-RUBOUT :FULL-RUBOUT)
								      (:ACTIVATION = #\END))
				  #'READ-FOR-TOP-LEVEL)
		       (COND ((EQ TEM :FULL-RUBOUT)
			      (GO LOOK-FOR-SPECIAL-KEYS)))
		       (SHIFTF +++ ++ + - TEM1))
		     (COND ((AND (CONSP -) (EQ (CAR -) 'RETURN))
			    (RETURN (EVAL-ABORT-TRIVIAL-ERRORS (CADR -)))))	;(RETURN form) proceeds
		     (LET (VALUES)
		       (UNWIND-PROTECT
			   (SETQ VALUES
				 (MULTIPLE-VALUE-LIST (EVAL-ABORT-TRIVIAL-ERRORS -)))
			 ;; Always push SOMETHING for each form evaluated.
			 (PUSH VALUES *VALUES*))
		       (SETQ /// // // / / VALUES)
		       (SETQ *** ** ** * * (CAR /)))
		     (DOLIST (VALUE /)
		       (TERPRI)
		       (FUNCALL (OR PRIN1 #'PRIN1) VALUE))
		     (SETQ THROW-FLAG NIL))
		 (WHEN THROW-FLAG
		   (FORMAT T "~&;Back to Breakpoint ~?  ~:@C to continue, ~:@C to quit.~%"
			   FORMAT-STRING ARGS #\RESUME #\ABORT)))))))
      ;; Before returning, restore and redisplay rubout handler's buffer so user
      ;; gets what he sees, if we broke out of reading through the rubout handler.
      ;; If we weren't inside there, the rubout handler buffer is now empty because
      ;; we read from it, so leave it alone.  (Used to :CLEAR-INPUT).
      (COND (SAVED-BUFFER
	     (FUNCALL OLD-STANDARD-INPUT :RESTORE-RUBOUT-HANDLER-BUFFER
		      SAVED-BUFFER SAVED-BUFFER-POSITION)))
      VALUE)))