;;; -*- LISP -*-
;;; QTRACE: A querying flavor of MacLISP TRACE/BREAK functions
;;;
;;; This file is intended primarily to be loaded into an interactive
;;;  environment. To use in a compiled file, it must be loaded into
;;;  both the compiled and runtime environment, since some of the
;;;  auxiliary functions are not implemented as macro's and would 
;;;  otherwise be undefined at runtime.
;;;
;;; Interesting functions defined in this file are:
;;;
;;; (QBREAK), (QBREAK <break-name>), (QBREAK <break-name> <condition>)
;;;   Works just like BREAK, but BREAK is conditionalized on
;;;   *QBREAK (see below).
;;;
;;; (QTRACE <specs1> <specs2> ... <specsN>)
;;;   Works just like TRACE, but will offer to BREAK at each call to
;;;   the functions specified (conditionalizing on *QBREAK).
;;;
;;; (*QBREAK <state>)
;;;   Changes the value of *QBREAK. (The user should not use
;;;   (SETQ *QBREAK <value>) or lambda-bind *QBREAK unless he is
;;;   certain that the value he is assigning to the *QBREAK 
;;;   variable is a legal one. The *QBREAK function does this sort
;;;   of type-checking to insure a legal value.
;;;
;;;    If <state>=ALWAYS,
;;;	  then QTRACE'd things and QBREAK will always break without 
;;;	       asking (if their other optional conditions are also satisfied). 
;;;
;;;    If <state>=NEVER
;;;       then QTRACE'd things and QBREAK will never break under any
;;;            circumstances.
;;;
;;;    If <state>=QUERY
;;;	  then QTRACE'd things and QBREAK will break only if any
;;;	       additional conditions given are satisfied AND the
;;;	       user also answers affirmatively to a query about whether
;;;	       or not to break.
;;;
;;;


(DECLARE (SPECIAL *QBREAK))

(COND ((NOT (BOUNDP '*QBREAK)) (SETQ *QBREAK 'QUERY)))

;;; QBREAK
;;;  Like BREAK but listens to the value of *QBREAK.

(DEFUN (QBREAK MACRO) (X)
       (COND ((> (LENGTH X) 3.)
	      (ERROR '|QBREAK called on too many args.| X)))
       `(BREAK ,(OR (CADR X) '|QBreak|)
	       ,(COND ((NULL (CDDR X)) '(*QBREAK$BREAK?))
		      ((MEMBER (CADDR X) '(T 'T)) '(*QBREAK$BREAK?))
		      (T `(AND ,(CADDR X) (*QBREAK$BREAK?))))))

;;; QTRACE
;;;  Reformat a TRACE into something that asks whether to break.
;;;  Called just like TRACE. Explicitly provided info about when
;;;  to break overrides the default.

(DEFUN (QTRACE MACRO) (X)
       (CONS 'TRACE (MAPCAR 'QTRACE$SETUP (CDR X))))

;;; QTRACE$SETUP
;;;  Looks to see that it isn't clobbering explicit info. Returns a
;;;  form that can be an arg to trace.

(DEFUN QTRACE$SETUP (X)
       (COND ((ATOM X) (LIST X 'BREAK '(*QBREAK$BREAK?)))
	     ((NOT (MEMQ 'BREAK X)) (APPEND X '(BREAK (*QBREAK$BREAK?))))
	     (T
	      (DO ((C (CDR X))
		   (L (NCONS (CAR X))))
		  ((NULL C) (NREVERSE L))
		  (PUSH (CAR C) L)
		  (COND ((NOT (EQ (POP C) 'BREAK))
			 (PUSH (POP C) L))
			(T
			 (COND ((MEMBER (CAR C) '(T 'T))
				(POP C)
				(PUSH '(*QBREAK$BREAK?) L))
			       (T
				(PUSH `(AND ,(POP C) (*QBREAK$BREAK?))
				      L)))))))))

;;; If *QBREAK is set to T, anything QTRACE'd will Break.

(DEFUN *QBREAK$BREAK? ()
       (COND ((EQ *QBREAK 'ALWAYS) T)
	     ((EQ *QBREAK 'QUERY) (QTRACE$QUERY))
	     ((EQ *QBREAK 'NEVER) NIL)
	     (T
	      (ERROR '|- Illegal value for *QBREAK.| *QBREAK)
	      (*QBREAK$BREAK?))))

(DEFUN QTRACE$QUERY ()
       (PROG (C)
	     (CLEAR-INPUT TYI)
	     (PRINC '|--Break?--| TYO)
	TOP  (SETQ C (TYI TYI))
	     (COND ((OR (= C 32.)  (= C 89.) (= C 121.))   ;Space,Y,y
		    (PRINC '| [Yes]| TYO)
		    (RETURN T))
		   ((OR (= C 127.) (= C 78.) (= C 110.))   ;Rubout,N,n
		    (PRINC '| [No]| TYO)
		    (RETURN NIL))
		   (T
		    (TERPRI TYO)
		    (PRINC '|Create a Breakpoint? (Y or N)| TYO)
		    (GO TOP)))))

(DEFUN (*QBREAK MACRO) (X)
       (SETQ X (CADR X))
       (COND ((OR (EQ X 'QUERY) (EQUAL X '(QUOTE QUERY)))
	      '(SETQ *QBREAK 'QUERY))
	     ((OR (EQ X 'NEVER) (EQUAL X '(QUOTE NEVER)))
	      '(SETQ *QBREAK 'NEVER))
	     ((OR (EQ X 'ALWAYS) (EQUAL X '(QUOTE ALWAYS)))
	      '(SETQ *QBREAK 'ALWAYS))
	     (T
	      (ERROR
	       '|Illegal value for *QBREAK. Use ALWAYS, NEVER, or QUERY.|))))