mirror of
https://github.com/PDP-10/its.git
synced 2026-03-22 09:03:20 +00:00
134 lines
3.8 KiB
Common Lisp
Executable File
134 lines
3.8 KiB
Common Lisp
Executable File
;;; -*- Mode: Lisp; IBase: 10.; -*-
|
||
;;; TRAP: A library for trapping errors at runtime
|
||
|
||
;;; (AWAIT val [pred])
|
||
;;;
|
||
;;; Sets up an EVALHOOK which looks for any evaluation or subevaluation
|
||
;;; which results in value, retval, which answers non-() to the test
|
||
;;; (FUNCALL pred retval val)
|
||
;;;
|
||
;;; The function pred defaults to #'EQ, for efficiency.
|
||
;;;
|
||
;;; Since it works by EVALHOOK, can work only on return values that go
|
||
;;; through the interpreter. Can't find such values in compiled code.
|
||
;;;
|
||
;;; Since Lisp resets EVALHOOK to NIL in breakpoints and globally, when
|
||
;;; a ^G or error quit is done, the effect of AWAIT may be fleeting. If
|
||
;;; it doesn't seem to be working, check to see that EVALHOOK has not
|
||
;;; been reset to NIL.
|
||
;;;
|
||
;;; Sample usage:
|
||
;;;
|
||
;;; (AWAIT 'FOO)
|
||
;;; => T
|
||
;;; (LIST (IMPLODE '(F O O)) 'BAR)
|
||
;;; ;BKPT Found It!
|
||
;;; (EVALFRAME NIL)
|
||
;;; => (APPLY -21746 (AWAIT-EVALHOOK ((IMPLODE (QUOTE (F O O))))) -7767)
|
||
;;; P
|
||
;;; => (FOO BAR)
|
||
;;;
|
||
|
||
(DECLARE (SPECIAL AWAIT-VALUE AWAIT-PREDICATE))
|
||
|
||
(DEFVAR AWAIT-PREDICATE () "Function to use in recognition of awaited values")
|
||
(DEFVAR AWAIT-VALUE () "Value being awaited")
|
||
|
||
(DEFUN AWAIT-EVALHOOK (EVAL-HOOK-VAR)
|
||
(LET ((RETURN-VALUE (EVALHOOK EVAL-HOOK-VAR 'AWAIT-EVALHOOK)))
|
||
(COND ((FUNCALL AWAIT-PREDICATE RETURN-VALUE AWAIT-VALUE)
|
||
(LET ((ARGS EVAL-HOOK-VAR))
|
||
(BREAK "Found it!" T))))
|
||
RETURN-VALUE))
|
||
|
||
(DEFMACRO AWAIT (&OPTIONAL (VAL () VAL?) (PRED '#'EQ))
|
||
(COND (VAL?
|
||
`(PROGN (SETQ AWAIT-PREDICATE ,PRED
|
||
AWAIT-VALUE ,VAL
|
||
EVALHOOK #'AWAIT-EVALHOOK)
|
||
T))
|
||
(T
|
||
(SETQ EVALHOOK ()))))
|
||
|
||
|
||
|
||
;;; (MAR-TRACE sym)
|
||
;;;
|
||
;;; sym is not evaluated. It should be a lisp symbol.
|
||
;;;
|
||
;;; Initializes a hardware trap on writes to the value cell of sym.
|
||
;;; Any attempt to set this variable from either compiled or interpreted
|
||
;;; code, including special variable binding in compiled code, will fire
|
||
;;; an interrupt to let you know.
|
||
;;;
|
||
;;; If the variable MAR-BREAKP is
|
||
;;; T Then a Lisp breakpoint will happen automatically.
|
||
;;; () Then a Lisp breakpoint will not happen, but
|
||
;;; notification will be typed out.
|
||
;;; QUERY Then Lisp will query if you want a breakpoint.
|
||
;;; This is the default behavior.
|
||
;;;
|
||
;;; Sample usage:
|
||
;;;
|
||
;;; (MAR-TRACE FOO)
|
||
;;; => T
|
||
;;; (SETQ FOO 5)
|
||
;;; ;Variable FOO being set to 5
|
||
;;; ;*** Break? (Y or N) Y (Yes)
|
||
;;; ;BKPT FOO
|
||
;;; (BAKTRACE)
|
||
;;; BAKTRACE
|
||
;;; MAR-HANDLER_ SETQ_
|
||
;;; => NIL
|
||
;;; P
|
||
;;; => 5
|
||
;;; (MAR-UNTRACE)
|
||
;;; => T
|
||
;;;
|
||
|
||
(DEFVAR MAR-BITS 2. "See .INFO.;LISP NEWS for info on bits")
|
||
(DEFVAR MAR-BREAK () "Handler to call on MAR interrupts")
|
||
(DEFVAR MAR-BREAKP 'QUERY "Ask before breaking")
|
||
(DEFVAR MAR-VARIABLE () "Variable being traced")
|
||
|
||
(SETQ MAR-BREAK #'MAR-HANDLER) ;; Lisp System variable. Was initially ()
|
||
|
||
(DEFUN MAR-HANDLER (())
|
||
(SSTATUS MAR MAR-BITS (MUNKAM (VALUE-CELL-LOCATION MAR-VARIABLE)))
|
||
(NOINTERRUPT NIL)
|
||
(TERPRI MSGFILES)
|
||
(PRINC ";Variable " MSGFILES)
|
||
(PRIN1 MAR-VARIABLE MSGFILES)
|
||
(PRINC " being set to " MSGFILES)
|
||
(PRIN1 (SYMEVAL MAR-VARIABLE) MSGFILES)
|
||
(TERPRI MSGFILES)
|
||
(*BREAK (AND MAR-BREAKP
|
||
(OR (EQ MAR-BREAKP T)
|
||
(PROG (CHAR)
|
||
(CLEAR-INPUT TYI)
|
||
TOP (CURSORPOS 'A TYO)
|
||
(PRINC ";**** Break? " TYO)
|
||
(SETQ CHAR (TYI TYI))
|
||
(COND ((OR (= CHAR #/Y)
|
||
(= CHAR #/y)
|
||
(= CHAR #\SPACE))
|
||
(PRINC " (Yes)" TYO)
|
||
(RETURN T))
|
||
((OR (= CHAR #/N)
|
||
(= CHAR #/n)
|
||
(= CHAR #\RUBOUT))
|
||
(PRINC " (No)" TYO)
|
||
(RETURN NIL))
|
||
(T (PRINC " ?? Answer 'Y' or 'N'")
|
||
(GO TOP))))))
|
||
MAR-VARIABLE))
|
||
|
||
(DEFMACRO MAR-TRACE (SYM)
|
||
`(PROGN (SETQ MAR-VARIABLE ',SYM)
|
||
(COND ((NOT (BOUNDP ',SYM)) (SETQ ,SYM 'UNBOUND)))
|
||
(SSTATUS MAR MAR-BITS (MUNKAM (VALUE-CELL-LOCATION ',SYM)))
|
||
T))
|
||
|
||
(DEFUN MAR-UNTRACE () (SSTATUS MAR 0 NIL) T)
|
||
|