mirror of
https://github.com/PDP-10/its.git
synced 2026-01-21 18:16:07 +00:00
129 lines
4.1 KiB
Common Lisp
Executable File
129 lines
4.1 KiB
Common Lisp
Executable File
;;; -*- LISP -*-
|
|
;;; QTRACE: A QBREAKing flavor of MacLISP TRACE
|
|
;;;
|
|
;;; 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 ()
|
|
(PROG1
|
|
(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
|
|
(CLEAR-OUTPUT TYO)
|
|
(COND ((= C 13.)
|
|
(COND ((AND (NOT (ZEROP (LISTEN)))
|
|
(= (TYIPEEK NIL TYI) 10.))
|
|
(TYI TYI)))) ; Eat accompanying linefeed
|
|
(T (TERPRI TYO)))
|
|
(PRINC '|Create a Breakpoint? (Y or N)| TYO)
|
|
(GO TOP))))
|
|
(COND ((NOT (ZEROP (LISTEN)))
|
|
(COND ((= (TYIPEEK NIL TYI) 13.)
|
|
(TYI TYI)))))
|
|
(COND ((NOT (ZEROP (LISTEN)))
|
|
(COND ((= (TYIPEEK NIL TYI) 10.)
|
|
(TYI TYI)))))))
|
|
|
|
(DEFUN *QBREAK FEXPR (X)
|
|
(SETQ X (CAR 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.|)))) |