; File:  DEBUG.LSP  (c)		08/15/85	Soft Warehouse, Inc.


(LOOP (PRIN1 '*) (EVAL (READ)) ((NULL RDS)) )


(DEFUN TRACE LST
  (STUB 'TRACE LST) )

(DEFUN BRK LST
  (STUB 'BRK LST) )

(DEFUN CLEAR LST
  (UNSTUB LST) )

(DEFUN HISTORY (
    LST)
  (SETQ! LST (CAR! HISTORY))
  (LOOP!
    ((EQ! LST))
    ( ((EQ! (CAR! LST)))
      (APPLY! (CAR! (CAR! LST)) (CDR! (CAR! LST))) )
    (POP! LST) ) )

(SETQ HISTLEN 15)

(DEFUN BACKTRACE (
    LST)
  (SETQ! LST (REVERSE! BTRLIST))
  (LOOP!
    ((EQ! LST))
    (APPLY! PRTCALL! (LIST! (CAR! (CAR! LST)) (CDR! (POP! LST)))) ) )

(DEFUN STUB (FLAG LST NAM
    NAM$)
  (SET FLAG T)
  (SETQ NAM$ T)
  (LOOP
    ((ATOM LST) NAM$)
    (SETQ NAM (POP LST))
    ( ((NOT (GETD NAM T))
	(SETQ NAM$)
	(PRIN1 NAM) (WRITE-LINE " is undefined") )
      (FLAG FLAG NAM)
      ((TRACED NAM))
      (PUT NAM 'DEBUG (CONS! (PACK* NAM '!) (COND
	  ((NUMBERP (GETD NAM)) NIL)
	  ((CADR (GETD NAM))) )))
      (MOVD NAM (CAR! (GET NAM 'DEBUG)))
      (PUTD NAM (LIST
		(IF (EQ (GETD NAM T) 'SPECIAL) 'NLAMBDA (GETD NAM T))
		'ARGLST! (LIST 'TRACE! NAM))) ) ) )

(DEFUN TRACED (NAM)
  (EQ (CAR (CADDR (GETD NAM))) 'TRACE!) )

(DEFUN UNSTUB (LST NAM)
  (SETQ LEVELCOUNT 0)
  (RPLACD 'LEVELCOUNT)
  (SETQ BTRLIST)
  (LOOP
    ((ATOM LST))
    (SETQ NAM (POP LST))
    ( ((GET NAM 'DEBUG)
	(REMFLAG 'BRK NAM)
	(REMFLAG 'TRACE NAM)
	(MOVD (CAR! (GET NAM 'DEBUG)) NAM)
	(REMPROP NAM 'DEBUG) ) ) ) )


(DEFUN TRACE! (NLAMBDA (NAM!
    LST!)
  ( ((AND! (EQ! LEVELCOUNT 0) RATOM)
      (SETQ! RATOM)
      (SETQ! HISTORY)
      (SETQ! CALLCOUNT 0)
      (RPLACD! 'CALLCOUNT)
      (SETQ! MAXLEVELCOUNT 0)
      (RPLACD! 'MAXLEVELCOUNT) ) )
  (PUTADD! 'CALLCOUNT NAM!)
  (PUTADD! 'LEVELCOUNT NAM!)
  ( ((<! LEVELCOUNT MAXLEVELCOUNT))
    (SETQ! MAXLEVELCOUNT LEVELCOUNT) )
  ( ((AND! (NUMBERP! (GET! 'MAXLEVELCOUNT NAM!))
	   (<! (GET! 'LEVELCOUNT NAM!) (GET! 'MAXLEVELCOUNT NAM!))))
    (PUT! 'MAXLEVELCOUNT NAM! (GET! 'LEVELCOUNT NAM!)) )
  ( ((EQ! BACKTRACE))
    (PUSH! (CONS! NAM! ARGLST!) BTRLIST) )
  (HISTORY! NAM! ARGLST! LEVELCOUNT 'PRTCALL!)
  ( ((TRACEP! NAM!)
      (PRTCALL! NAM! ARGLST! LEVELCOUNT) ) )
  ( ((AND! BRK
	(FLAGP! 'BRK NAM!)
	(LEQ! MINCALL CALLCOUNT)
	(LEQ! (GET! 'MINCALL NAM!) (GET! 'CALLCOUNT NAM!))
	(OR! (EQ! (NUMBERP! BRKLEVEL))
	     (EQ! LEVELCOUNT BRKLEVEL) )
	(OR! (EQ! (NUMBERP! (GET! 'BRKLEVEL NAM!)))
	     (EQ! (GET! 'LEVELCOUNT NAM!) (GET! 'BRKLEVEL NAM!)))
	(OR! (EQ! (SETQ! LST! (GET! 'DEBUGIN NAM!)))
	     (LOOP!
		((ATOM! LST!) NIL)
		((ASSOC! (POP! LST!) BTRLIST)) )) )
      (TERPRI!)
      (PRINC! "Break-point:  ")
      (PRTCALL! NAM! ARGLST!)
      (SETQ! LST! (BREAK!)) ) )
  ((EQ! (EQ! LST!)))
  (SETQ! ARGLST! (APPLY! (CAR! (GET! NAM! 'DEBUG)) ARGLST!))
  (HISTORY! NAM! ARGLST! LEVELCOUNT 'PRTRSLT!)
  ( ((TRACEP! NAM!)
      (PRTRSLT! NAM! ARGLST! LEVELCOUNT) ) )
  ( ((EQ! NAM! (CAR! (CAR! BTRLIST)))
      (POP! BTRLIST) ) )
  (PUTSUB! 'LEVELCOUNT NAM!)
  ARGLST! ))

(DEFUN TRACEP! (NAM!
     LST!)
   (AND! TRACE
	(FLAGP! 'TRACE NAM!)
	(LEQ! MINCALL CALLCOUNT)
	(LEQ! MINLEVEL LEVELCOUNT)
	(LEQ! LEVELCOUNT MAXLEVEL)
	(LEQ! (GET! 'MINLEVEL NAM!) (GET! 'LEVELCOUNT NAM!))
	(LEQ! (GET! 'LEVELCOUNT NAM!) (GET! 'MAXLEVEL NAM!))
	(OR! (EQ! (SETQ! LST! (GET! 'DEBUGIN NAM!)))
	     (LOOP!
	       ((ATOM! LST!) NIL)
	       ((ASSOC! (POP! LST!) BTRLIST)) ) ) ) )

(DEFUN LEQ! (NUM1 NUM2)
    (OR! (EQ! (NUMBERP! NUM1))
	(EQ! (NUMBERP! NUM2))
	(EQ! NUM1 NUM2)
	(<! NUM1 NUM2) ) )

(DEFUN HISTORY! (NAM LST NUM NAM1)
  (SETQ! HISTORY (TCONC! HISTORY (LIST! NAM1 NAM LST NUM)))
  ((<! HISTLEN (LENGTH! (CAR! HISTORY)))
    (RPLACA! HISTORY (CDR! (CAR! HISTORY))) ) )

(DEFUN PUTADD! (NAM1 NAM2)
  ((EQ! (NUMBERP! (CAR! NAM1))))
  (SET! NAM1 (+! (CAR! NAM1) 1))
  ((NUMBERP! (GET! NAM1 NAM2))
    (PUT! NAM1 NAM2 (+! (GET! NAM1 NAM2) 1)) )
  (PUT! NAM1 NAM2 1) )

(DEFUN PUTSUB! (NAM1 NAM2)
  ((EQ! (NUMBERP! (CAR! NAM1))))
  ( ((EQ! (CAR! NAM1) 0))
    (SET! NAM1 (+! (CAR! NAM1) -1)) )
  ((NUMBERP! (GET NAM1 NAM2))
    ((<! 0 (GET NAM1 NAM2))
      ((EQ! (GET NAM1 NAM2) 1)
        (REMPROP! NAM1 NAM2) )
      (PUT! NAM1 NAM2 (+! (GET! NAM1 NAM2) -1)) ) ) )

(DEFUN PRTCALL! (NAM LST NUM)
  (PRTNAM!)
  (SETQ! NAM (CDR! (GET! NAM 'DEBUG)))
  (PRINC! '"[")
  ( ((EQ! NAM)
      ((ATOM! LST))
      (LOOP!
	(PRTEXP! NAM (POP! LST))
	((ATOM! LST))
	(PRINC! ", ") ) )
    ((ATOM! NAM)
      (PRINC! NAM)
      (PRINC! ": ")
      (PRTEXP! NAM LST) )
    (LOOP!
      (PRINC! (CAR! NAM))
      (PRINC! ": ")
      (PRTEXP! (POP! NAM) (POP! LST))
      ((ATOM! NAM)
	((ATOM! LST))
	(LOOP!
	  (PRTEXP! NAM (POP! LST))
	  ((ATOM! LST))
	  (PRINC! ", ") ) )
      (PRINC! ", ") ) )
  (PRINC! '"]")
  (TERPRI!) )

(DEFUN PRTRSLT! (NAM LST NUM)
  (PRTNAM!)
  (PRINC! "= ")
  (PRTEXP! NAM LST)
  (TERPRI!) )

(DEFUN PRTNAM! ()
  ( ((NUMBERP! NUM)
      (FRESH-LINE)
      ( ((<! NUM 10)
          (SPACES! 1) ) )
      (PRINC! NUM)
      (PRINC! '"|")
      (SPACES! NUM) ) )
  (PRINC! NAM)
  (SPACES! 1) )

(DEFUN PRTEXP! (NAM EXP)
  (PRINC! EXP) )


(MOVD 'CAR 'CAR!)
(MOVD 'CDR 'CDR!)
(MOVD 'ASSOC 'ASSOC!)
(MOVD 'CONS 'CONS!)
(MOVD 'LIST 'LIST!)
(MOVD 'REVERSE 'REVERSE!)
(MOVD 'RPLACA 'RPLACA!)
(MOVD 'RPLACD 'RPLACD!)
(MOVD 'TCONC 'TCONC!)
(MOVD 'GET 'GET!)
(MOVD 'PUT 'PUT!)
(MOVD 'REMPROP 'REMPROP!)
(MOVD 'FLAGP 'FLAGP!)
(MOVD 'ATOM 'ATOM!)
(MOVD 'NUMBERP 'NUMBERP!)
(MOVD 'EQ 'EQ!)
(MOVD '< '<!)
(MOVD 'SET 'SET!)
(MOVD 'SETQ 'SETQ!)
(MOVD '+ '+!)
(MOVD 'LENGTH 'LENGTH!)
(MOVD 'PRINC 'PRINC!)
(MOVD 'TERPRI 'TERPRI!)
(MOVD 'SPACES 'SPACES!)
(MOVD 'APPLY 'APPLY!)
(MOVD 'BREAK 'BREAK!)
(MOVD 'LOOP 'LOOP!)
(MOVD 'AND 'AND!)
(MOVD 'OR 'OR!)
(MOVD 'POP 'POP!)
(MOVD 'PUSH 'PUSH!)

(CLEAR)

(RDS)