mirror of
https://github.com/PDP-10/its.git
synced 2026-03-21 08:48:51 +00:00
777 lines
23 KiB
Groff
777 lines
23 KiB
Groff
;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;; ERROR > -- DEBUGGING PRIMITIVES ;;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;;
|
||
|
||
(DECLARE (OR (STATUS FEATURE DEFINE)
|
||
(COND ((STATUS FEATURE ITS)
|
||
;;MULTICS?
|
||
(FASLOAD DEFINE FASL DSK LLOGO)))))
|
||
|
||
(SAVE-VERSION-NUMBER ERROR)
|
||
|
||
(DECLARE (GENPREFIX ERROR))
|
||
|
||
;;; TRACE, GRIND, GRINDEF AND LAP MUST HAVE SPECIAL PARSING
|
||
;;; PROPERTIES. ANY FUNCTION WHICH HAS AUTOLOAD PROPERTY
|
||
;;; MUST TELL PARSER HOW IT WANTS TO BE PARSED. THE PARSER
|
||
;;; HAS NO WAY OF KNOWING WHAT IS GOING TO HAPPEN TO A FUNCTION
|
||
;;; WHEN ITS DEFINITION IS READ IN.
|
||
|
||
(DEFINE TRACE (PARSE F))
|
||
|
||
(DEFINE GRINDEF (PARSE F))
|
||
|
||
(DEFINE GRIND (PARSE F))
|
||
|
||
[(OR ITS DEC10) (DEFINE LAP (PARSE F))]
|
||
|
||
[(AND (NOT BIBOP) (NOT MULTICS)) (SETQ GC-DAEMON 'GC-DAEMON)
|
||
(DEFUN GC-DAEMON (X)
|
||
;;GC-DAEMON SERVICE FN. X = 3 DOTTED PAIRS
|
||
;;WHOSE CAR IS BEFORE GC, CDR AFTER GC. THE
|
||
;;PAIRS ARE FOR LIST, FIX AND FLO SPACE.
|
||
;;CURRENTLY A MESSAGE IS PRINTED.
|
||
(OR
|
||
(> (CDDAR X) 512.)
|
||
(COND
|
||
((< (CDDAR X) 100.)
|
||
;;AVAIBLE SPACE BELOW 100. WORDS --
|
||
;;EXTREME STORAGE CRUNCH.
|
||
(GCTWA)
|
||
(TYPE
|
||
'";FREE SPACE VERY TIGHT. LESS THAN 100 WORDS"
|
||
EOL)
|
||
(AND
|
||
(STATUS FEATURE TRACE)
|
||
(TYPE
|
||
'";ERASING TRACE"
|
||
EOL)
|
||
(REMTRACE))
|
||
(AND
|
||
(OR (STATUS FEATURE GRIND)
|
||
(STATUS FEATURE GRINDEF))
|
||
(TYPE
|
||
'";ERASING GRIND PACKAGE"
|
||
EOL)
|
||
(REMGRIND)))
|
||
((< (CDDAR X) 512.)
|
||
;;AVAILABLE SPACE MORE THAN 100 WORDS BUT
|
||
;;LESS THAN .5 BLOCKS.
|
||
(GCTWA)
|
||
(TYPE
|
||
'";FREE SPACE LESS THAN HALF-BLOCK"
|
||
EOL)))))]
|
||
|
||
[BIBOP (SETQ GC-OVERFLOW 'GC-OVERFLOW-HANDLER)
|
||
(DEFUN GC-OVERFLOW-HANDLER (X)
|
||
(IOG
|
||
NIL
|
||
(TYPE EOL
|
||
'";YOU HAVE RUN OUT OF "
|
||
X
|
||
'" SPACE. MORE?: ")
|
||
;;Ask if more memory desired.
|
||
(COND
|
||
((ASK)
|
||
(TYPE '"; OK. (")
|
||
;;If so, allocate some.
|
||
(ALLOC
|
||
(LIST
|
||
X
|
||
(LIST NIL
|
||
(LET ((NEW-ALLOC (+ (CDR (SASSQ X
|
||
'((LIST . 1400.)
|
||
(FIXNUM . 1400.)
|
||
(FLONUM . 600.)
|
||
(BIGNUM . 400.)
|
||
(SYMBOL . 400.)
|
||
(SAR . 100.))
|
||
'(LAMBDA NIL
|
||
'(NIL . 400.))))
|
||
(CADR (GET (CONS NIL (ALLOC T)) X)))))
|
||
(DPRINC NEW-ALLOC)
|
||
NEW-ALLOC)
|
||
NIL)))
|
||
(TYPE '" WORDS)" EOL))
|
||
((ERROR '"SPACE CAN'T BE EXPANDED"
|
||
X
|
||
'GC-LOSSAGE)))))
|
||
(SETQ GC-LOSSAGE 'GC-LOSSAGE-HANDLER)
|
||
(DEFUN GC-LOSSAGE-HANDLER (WHAT-TYPE)
|
||
(LIST
|
||
(ERRBREAK
|
||
(LIST WHAT-TYPE
|
||
'" STORAGE CAPACITY EXCEEDED"))))
|
||
(SETQ PDL-OVERFLOW 'STACK-OVERFLOW-HANDLER)]
|
||
|
||
[(OR BIBOP MULTICS) (DEFUN STACK-OVERFLOW-HANDLER (STACK-TYPE)
|
||
(IOG
|
||
NIL
|
||
(TYPE
|
||
EOL
|
||
'";TOO MANY RECURSIONS. USED "
|
||
(STATUS PDLSIZE STACK-TYPE)
|
||
'" WORDS. CONTINUE ANYWAY? ")
|
||
(COND
|
||
((ASK)
|
||
(TYPE '"; OK.")
|
||
(TERPRI)
|
||
(ALLOC (LIST STACK-TYPE
|
||
(MIN (STATUS PDLROOM STACK-TYPE)
|
||
(+ (GET (CONS NIL (ALLOC T))
|
||
STACK-TYPE)
|
||
400.)))))
|
||
((ERROR
|
||
'"SPACE OVERFLOW. CAN'T GET ANY MORE SPACE. "
|
||
STACK-TYPE)))))]
|
||
|
||
;;; TYPE CHECKING FUNCTIONS.
|
||
|
||
(DECLARE (MACROS NIL))
|
||
|
||
;(DEFUN SYMBOLP (X) (AND (EQ (TYPEP X) 'SYMBOL) X))
|
||
|
||
(DEFUN VARIABLEP (CHECKER VAR)
|
||
;;USED BY EDIT, LIST TO DECIDE LEGALITY OF VARIABLE NAME.
|
||
(COND
|
||
((AND (SYMBOLP VAR) (EQ (GETCHAR VAR 1.) ':)) VAR)
|
||
((ERRBREAK
|
||
CHECKER
|
||
(LIST VAR
|
||
'" IS NOT A VALID VARIABLE NAME")))))
|
||
|
||
(DEFUN NUMBER? (CHECKER NUMBER)
|
||
(COND ((NUMBERP NUMBER) NUMBER)
|
||
((ERRBREAK CHECKER
|
||
(LIST NUMBER
|
||
'" IS NOT A NUMBER")))))
|
||
|
||
(DEFUN PROCEDUREP (CHECKER CHECKED)
|
||
(COND
|
||
((NOT (SYMBOLP CHECKED))
|
||
(ERRBREAK
|
||
CHECKER
|
||
(LIST CHECKED
|
||
'" IS NOT A VALID PROCEDURE NAME")))
|
||
((EQ (GETCHAR CHECKED 1.) ':)
|
||
(ERRBREAK
|
||
CHECKER
|
||
(LIST
|
||
CHECKED
|
||
'" LOOKS LIKE A VARIABLE NAME -NOT A VALID PROCEDURE NAME")))
|
||
((ABBREVIATIONP CHECKED))
|
||
((MEMQ CHECKED :CONTENTS) CHECKED)
|
||
((GETL CHECKED '(SUBR FSUBR LSUBR))
|
||
(ERRBREAK CHECKER
|
||
(LIST CHECKED
|
||
'" IS A COMPILED FUNCTION")))
|
||
((ERRBREAK
|
||
CHECKER
|
||
(LIST CHECKED
|
||
'" IS NOT A DEFINED PROCEDURE ")))))
|
||
|
||
(DEFUN REREAD-ERROR (MESSAGE)
|
||
;;CAUSES MESSAGE TO BE PRINTED AND LINE REREAD.
|
||
(IOG NIL
|
||
(COND (REREAD-ERROR? (ERR 'REREAD))
|
||
(T (TYPE '/; MESSAGE EOL)
|
||
(LET ((NEW-LINE (REPAIR-LINE OLD-LINE)))
|
||
(TYPE '";CONTINUING EVALUATION"
|
||
EOL)
|
||
(THROW NEW-LINE PARSELINE))))))
|
||
|
||
(DEFUN PASS2-ERROR (MESSAGE)
|
||
;;IN THE SAME VEIN AS REREAD-ERROR EXCEPT INTENDED TO CATCH PASS2 ERRORS.
|
||
;;THROWS BACK TO PASS2 [AND LINE IF CALLED BY IT]
|
||
(IOG NIL
|
||
(LET ((PROMPTER '>))
|
||
(TYPE '/; MESSAGE EOL)
|
||
(MAPC 'DPRINC OLD-LINE)
|
||
(DTERPRI)
|
||
(DPRINC PROMPTER)
|
||
(LET ((NEW-LINE (LINE NIL)))
|
||
(TYPE '";CONTINUING EVALUATION"
|
||
EOL)
|
||
(THROW NEW-LINE PASS2)))))
|
||
|
||
;;*PAGE
|
||
|
||
;;; BREAKPOINT FUNCTIONS AND STACK HACKING
|
||
;;; :ERRBREAK = T --> LOGO BREAK POINT HAPPENS AUTOMATICALLY ON ERRORS.
|
||
;;; :LISPBREAK = T ---> LISP BREAK ON ERRORS.
|
||
|
||
(SETQ :ERRBREAK NIL :LISPBREAK NIL)
|
||
|
||
(DEFINE DEBUG NIL (SETQ :ERRBREAK (NOT :ERRBREAK)))
|
||
|
||
(DEFINE TOPLEVEL NIL (IOC G))
|
||
|
||
;;UP, DOWN, PRINTUP, PRINTDOWN ARE FOR USE INSIDE FRAMEUP BREAKS.
|
||
;;;(UP) GOES UP TO THE NEXT FRAME ON THE STACK.
|
||
;;;(UP <NUMBER>) GO UP <NUMBER> FRAMES.
|
||
;;;(UP <ATOM>) GO SEARCHING UP THE STACK FOR AN INVOCATION OF <ATOM>
|
||
;;;(UP <ATOM> <NUMBER>) FIND THE <NUMBER>TH INVOCATION OF <ATOM> UP THE STACK.
|
||
;;;DOWN IS SIMILAR, EXCEPT PROCEEDS DOWN THE STACK.
|
||
;;;DOWN IS EQUIVALENT TO (UP ... - <NUMBER>)
|
||
;;THE FUNCTIONS WORK BY THROWING A LIST BACK TO A CATCH IN FRAMEUP.
|
||
;;;FORMAT OF LIST IS:
|
||
;;; (<FUNCTION> <FUNCTION TO FIND> <NUMBER OF FRAMES> <1 IF UP, -1 IF DOWN>)
|
||
|
||
(DEFUN FRAMEUP-THROW (TYPE HOW-MANY-ARGS ARGLIST DIRECTION)
|
||
(THROW
|
||
(CONS TYPE
|
||
(LET ((HOW-MANY-FRAMES (CAR (LAST ARGLIST)))
|
||
(FIND-FUNCTION (AND (SYMBOLP (CAR ARGLIST)) (CAR ARGLIST))))
|
||
(COND ((ZEROP HOW-MANY-ARGS) (LIST NIL 1. DIRECTION))
|
||
((> HOW-MANY-ARGS 2.)
|
||
(TYPE '";TOO MANY INPUTS TO "
|
||
TYPE
|
||
EOL)
|
||
'(NIL 0. 1.))
|
||
((FIXP HOW-MANY-FRAMES)
|
||
(LIST FIND-FUNCTION
|
||
(ABS HOW-MANY-FRAMES)
|
||
(COND ((MINUSP (* DIRECTION HOW-MANY-FRAMES)) -1.)
|
||
(1.))))
|
||
(FIND-FUNCTION (LIST FIND-FUNCTION 1. DIRECTION))
|
||
(T (TYPE '";WRONG TYPE INPUTS TO "
|
||
TYPE
|
||
EOL)
|
||
'(NIL 0. 1.)))))
|
||
FRAMEUP-BREAK))
|
||
|
||
(DEFINE UP N (FRAMEUP-THROW 'UP N (LISTIFY N) 1.))
|
||
|
||
[(OR ITS DEC10) (ARGS 'UP '(0. . 2.))]
|
||
|
||
(DEFINE DOWN N (FRAMEUP-THROW 'DOWN N (LISTIFY N) -1.))
|
||
|
||
[(OR ITS DEC10) (ARGS 'DOWN '(0. . 2.))]
|
||
|
||
;;PRINTUP AND PRINTDOWN ARE LIKE UP AND DOWN, EXCEPT THAT THEY JUST PRINT OUT EVERY
|
||
;;FRAME BETWEEN THE CURRENT AND DESTINATION FRAMES RATHER THAN MOVING THE
|
||
;;BREAKPOINT. THE BREAKPOINT IS NOT AFFECTED.
|
||
|
||
(DEFINE PRINTUP N (FRAMEUP-THROW 'PRINTUP N (LISTIFY N) 1.))
|
||
|
||
[(OR ITS DEC10) (ARGS 'PRINTUP '(0. . 2.))]
|
||
|
||
(DEFINE PRINTDOWN N (FRAMEUP-THROW 'PRINTDOWN N (LISTIFY N) -1.))
|
||
|
||
[(OR ITS DEC10) (ARGS 'PRINTDOWN '(0. . 2.))]
|
||
|
||
;;EXIT CAUSES THE FORM IN THE CURRENT FRAME TO RETURN WITH THE SPECIFIED VALUE.
|
||
;;DEFAULTS TO NIL.
|
||
|
||
(DEFINE EXIT ARGS
|
||
[ITS (UNBIND-ACTIVATE)]
|
||
(THROW (LIST 'EXIT (AND (= ARGS 1.) (ARG 1.))) FRAMEUP-BREAK))
|
||
|
||
[(OR ITS DEC10) (ARGS 'EXIT '(0. . 1.))]
|
||
|
||
(DEFINE CONTINUE (ABB CO P $P) ARGS
|
||
[ITS (UNBIND-ACTIVATE)]
|
||
(THROW (CONS 'CONTINUE (AND (= ARGS 1.) (LIST (ARG 1.))))
|
||
FRAMEUP-BREAK))
|
||
|
||
[(OR ITS DEC10) (ARGS 'CONTINUE '(0. . 1.))]
|
||
|
||
;;THE USER IS PUT IN A BREAKPOINT FROM WHICH HE CAN USE THE FUNCTIONS UP, DOWN, AND
|
||
;;EXIT TO MOVE THE BREAKPOINT AROUND THE STACK. FORMAT OF A LISP FRAME IS
|
||
;;; (<EVAL OR APPLY> <STACK-POINTER> <FORM> <ENV>)
|
||
;;;FRAMEUP REQUIRES *RSET = T.
|
||
;;;
|
||
|
||
(DEFUN FRAMEUP (CONTINUE-VALUE FRAME FRAME-PRINT BREAK-LOOP)
|
||
(DO ((FRAME-NUMBER 0.)
|
||
(FORM (CADDR FRAME))
|
||
(ENV (CADDDR FRAME))
|
||
(*RSET)
|
||
(NEW-FRAME)
|
||
;;;TO INITIALIZE STACK POINTER, MUST LEAVE
|
||
;;;ERROR OR FRAMEUP FRAMES.
|
||
(STACK-POINTER (CADR FRAME))
|
||
(CAUGHT)
|
||
(SECOND-CAUGHT))
|
||
(NIL)
|
||
(TYPE '";BREAKPOINT FRAME "
|
||
FRAME-NUMBER
|
||
'": ")
|
||
(EXPR-CALL FRAME-PRINT FORM)
|
||
(SETQ CAUGHT (CATCH (APPLY BREAK-LOOP NIL ENV) FRAMEUP-BREAK)
|
||
;;UNLABELLED THROWS OUT OF THIS LOOP ARE HIGHLY DISCOURAGED.
|
||
SECOND-CAUGHT (CADR CAUGHT))
|
||
(AND (EQ (CAR CAUGHT) 'EXIT) (FRETURN STACK-POINTER SECOND-CAUGHT))
|
||
(AND (EQ (CAR CAUGHT) 'CONTINUE)
|
||
(RETURN (COND ((CDR CAUGHT) SECOND-CAUGHT) (CONTINUE-VALUE))))
|
||
(DO ((HOW-MANY-FRAMES (CADDR CAUGHT))
|
||
;;;IF LOOKING FOR A PARTICULAR FN, COUNT-THIS-FRAME
|
||
;;;IS TRUE ONLY FOR RELEVANT FRAMES.
|
||
(COUNT-THIS-FRAME T)
|
||
;;;DIRECTION = 1 IF UP, -1 IF DOWN.
|
||
(DIRECTION (CADDDR CAUGHT))
|
||
(PRINTFRAMES (AND (MEMQ (CAR CAUGHT) '(PRINTUP PRINTDOWN))
|
||
(CONS FRAME-NUMBER FRAME))))
|
||
((OR (AND COUNT-THIS-FRAME (ZEROP HOW-MANY-FRAMES))
|
||
;;;GO DOWN TOO FAR??
|
||
(AND (MINUSP DIRECTION) (ZEROP FRAME-NUMBER))
|
||
;;;GO UP TOO FAR??
|
||
(NULL (SETQ NEW-FRAME (EVALFRAME (* DIRECTION STACK-POINTER)))))
|
||
(AND PRINTFRAMES
|
||
(SETQ FRAME-NUMBER (CAR PRINTFRAMES)
|
||
FRAME (CDR PRINTFRAMES)
|
||
STACK-POINTER (CADR FRAME)
|
||
FORM (CADDR FRAME)
|
||
ENV (CADDDR FRAME))))
|
||
(SETQ FRAME NEW-FRAME
|
||
FRAME-NUMBER (+ FRAME-NUMBER DIRECTION)
|
||
STACK-POINTER (CADR FRAME)
|
||
FORM (CADDR FRAME)
|
||
ENV (CADDDR FRAME)
|
||
COUNT-THIS-FRAME (OR (NULL SECOND-CAUGHT)
|
||
(AND (NOT (ATOM FORM))
|
||
(EQ (CAR FORM) SECOND-CAUGHT))))
|
||
(AND COUNT-THIS-FRAME (DECREMENT HOW-MANY-FRAMES))
|
||
(AND PRINTFRAMES
|
||
(TYPE '";FRAME "
|
||
FRAME-NUMBER
|
||
'": ")
|
||
(EXPR-CALL FRAME-PRINT FORM)
|
||
(DTERPRI)))))
|
||
|
||
;;IS THIS BREAK LOOP ENTIRELY CORRECT? GLS CLAIMS NOT. ERROR KEEPS OLD VALUE OF +?
|
||
|
||
(DEFUN LISP-BREAK-LOOP FEXPR (USELESS)
|
||
(DO ((^W)
|
||
(^Q)
|
||
(^R)
|
||
(+)
|
||
(- -)
|
||
(OBARRAY LISP-OBARRAY)
|
||
(READTABLE LISP-READTABLE))
|
||
(NIL)
|
||
(DTERPRI)
|
||
(SETQ + - - (READ))
|
||
(COND
|
||
;;ALT-P CONTINUES WITH DEFAULT LIKE OLD BREAK. DOLLAR-P FOR
|
||
;;BENEFIT OF ALTMODE-LESS MULTICS HACKERS.
|
||
((MEMQ - '($P P)) (CONTINUE))
|
||
;;ALSO SIMULATE (RETURN ..) KLUDGE.
|
||
((AND (NOT (ATOM -)) (EQ (CAR -) 'RETURN))
|
||
(CONTINUE (EVAL (CADR -))))
|
||
((ERRSET (DPRINT (SETQ * (EVAL -))))))))
|
||
|
||
(DEFUN LOGO-BREAK-LOOP NIL
|
||
(DO ((^W)
|
||
(^Q)
|
||
(^R)
|
||
(PROMPTER '%)
|
||
(LOGOVALUE)
|
||
(OLD-LINE OLD-LINE)
|
||
(FN FN)
|
||
(PROG PROG)
|
||
(TITLE TITLE)
|
||
(REQUEST? NIL))
|
||
;;REBIND ANYTHING WHICH MIGHT BE ADVERSELY AFFECTED BY A BREAKPOINT.
|
||
(NIL)
|
||
(ERRSET (SETQ LOGOVALUE (TOP-LEVEL)))))
|
||
|
||
;;HANDLES ARG CHECKING, ETC. FOR BOTH LISPBREAK AND LOGOBREAK.
|
||
|
||
(DEFUN BREAK-POINT (ARG-LIST ENV UP-TO FRAME-PRINT BREAK-LOOP)
|
||
(LET ((HOW-MANY-ARGS (LENGTH ARG-LIST)) (^W NIL) (^Q NIL) (^R NIL))
|
||
(COND ((> HOW-MANY-ARGS 3.)
|
||
(ERRBREAK UP-TO '"TOO MANY ARGS"))
|
||
((AND (> HOW-MANY-ARGS 1.) (NULL (EVAL (CADR ARG-LIST) ENV)))
|
||
NO-VALUE)
|
||
(T (AND (PLUSP HOW-MANY-ARGS)
|
||
(TYPE EOL
|
||
'";BREAKPOINT "
|
||
(CAR ARG-LIST)
|
||
EOL))
|
||
(FRAMEUP (AND (= HOW-MANY-ARGS 3.) (EVAL (CADDR ARG-LIST) ENV))
|
||
UP-TO
|
||
FRAME-PRINT
|
||
BREAK-LOOP)))))
|
||
|
||
;;YEAH, I KNOW I'M REDEFINING BREAK. AVOID WARNING MESSAGE.
|
||
|
||
(REMPROP 'BREAK 'FSUBR)
|
||
|
||
(DEFINE LISPBREAK (ABB BREAK) FEXPR (ARGS ENV)
|
||
[ITS (BIND-ACTIVATE-LISP)]
|
||
(BREAK-POINT ARGS
|
||
ENV
|
||
(STACK-SEARCH (EVALFRAME NIL) 'LISPBREAK)
|
||
(EXPR-FUNCTION DPRINC)
|
||
(FUNCTION LISP-BREAK-LOOP)))
|
||
|
||
(DEFPROP LISPBREAK ((PARSE-BREAK)) PARSE)
|
||
(DEFPROP LISPBREAK (UNPARSE-EXPR-FORM) PARSE)
|
||
|
||
(DEFINE LOGOBREAK (ABB PAUSE) FEXPR (ARGS ENV)
|
||
[ITS (BIND-ACTIVATE-LOGO)]
|
||
(BREAK-POINT ARGS
|
||
ENV
|
||
(STACK-SEARCH (EVALFRAME NIL) 'LOGOBREAK)
|
||
(EXPR-FUNCTION UNPARSE-PRINT-FORM)
|
||
(FUNCTION LOGO-BREAK-LOOP)))
|
||
|
||
(DEFPROP LOGOBREAK ((PARSE-BREAK)) PARSE)
|
||
(DEFPROP LOGOBREAK (UNPARSE-EXPR-FORM) UNPARSE)
|
||
|
||
;;*PAGE
|
||
|
||
|
||
(SSTATUS TTYINT #^^ 'TOGGLE-WORLD)
|
||
|
||
(DEFUN TOGGLE-WORLD (IGNORE)
|
||
;;^^ SWITCHES BACK AND FORTH BETWEEN LOGO AND LISP.
|
||
(NOINTERRUPT NIL)
|
||
(COND ((EQ OBARRAY LISP-OBARRAY)
|
||
[ITS (DO I (LISTEN) (1- I) (= I 0.) (TYI))]
|
||
(LOGO)
|
||
;;ERR FORCES BACK TO TOP LEVEL.
|
||
(ERR))
|
||
(T (TYPE '* EOL)
|
||
[ITS (DO I (LISTEN) (1- I) (= I 0.) (TYI))]
|
||
(LISP))))
|
||
|
||
(SSTATUS TTYINT #^H 'CONTROL-H-BREAK)
|
||
|
||
(DEFUN CONTROL-H-BREAK (^H)
|
||
;;^H ENTERS A LISP BREAK FROM EITHER LOGO OR LISP.
|
||
(NOINTERRUPT NIL)
|
||
[ITS (BIND-ACTIVATE-LISP)]
|
||
(BREAK-POINT '(CONTROL-H)
|
||
NIL
|
||
(STACK-SEARCH (EVALFRAME NIL) 'CONTROL-H-BREAK)
|
||
(EXPR-FUNCTION DPRINC)
|
||
'LISP-BREAK-LOOP))
|
||
|
||
(SSTATUS TTYINT #^A 'CONTROL-A-BREAK)
|
||
|
||
(DEFUN CONTROL-A-BREAK (USELESS)
|
||
;;CONTROL-A ENTERS A LOGO BREAK.
|
||
(NOINTERRUPT NIL)
|
||
[ITS (BIND-ACTIVATE-LOGO)]
|
||
(BREAK-POINT '(CONTROL-A)
|
||
NIL
|
||
(STACK-SEARCH (EVALFRAME NIL) 'CONTROL-A-BREAK)
|
||
(EXPR-FUNCTION UNPARSE-PRINT-FORM)
|
||
'LOGO-BREAK-LOOP))
|
||
|
||
(DEFUN STACK-SEARCH (START-FRAME LOOKING-FOR)
|
||
;;FINDS THE FIRST CALL TO LOOKING-FOR ON THE STACK SEARCHING UPWARD FROM
|
||
;;START-FRAME USING EVALFRAME.
|
||
(DO ((THIS-FRAME START-FRAME (EVALFRAME STACK-POINTER))
|
||
(STACK-POINTER (CADR START-FRAME) (CADR THIS-FRAME)))
|
||
((OR (NULL THIS-FRAME) (EQ (CAADDR THIS-FRAME) LOOKING-FOR)) THIS-FRAME)))
|
||
|
||
(DEFUN STACK-HACK (START-FRAME MESSAGE)
|
||
;;SEARCHES STACK FOR BAD FORM, USER FUNCTION, LINE NUMBER. PRINTS ERROR
|
||
;;MESSAGES.
|
||
(COND ((EQ (CAR (CADDR START-FRAME)) 'ERRBREAK)
|
||
;;DON'T USE FRAME WITH CALL TO ERRBREAK FUNCTION.
|
||
(SETQ START-FRAME (EVALFRAME (CADR START-FRAME)))))
|
||
(DO
|
||
((PROG-FRAME (STACK-SEARCH START-FRAME 'PROG)
|
||
;;SEARCH FOR FRAME CONTAINING PROG.
|
||
(STACK-SEARCH ABOVE-PROG 'PROG))
|
||
(ABOVE-PROG)
|
||
(USER-FUNCTION))
|
||
((COND
|
||
((NULL PROG-FRAME))
|
||
((MEMQ
|
||
(SETQ USER-FUNCTION
|
||
(CAADDR (SETQ ABOVE-PROG (EVALFRAME (CADR PROG-FRAME)))))
|
||
:CONTENTS)
|
||
;;LOGO USER FUNCTIONS DISTINGUISHED BY BEING MEMQ :CONTENTS. FRAME
|
||
;;IMMEDIATELY BENEATH LOGO USER FUNCTION IS ALWAYS A PROG.
|
||
(LET ((BAD-LINE-NUMBER (ERROR-LINE-NUMBER PROG-FRAME))
|
||
(PROG)
|
||
(THIS-LINE)
|
||
(NEXT-TAG)
|
||
(LAST-LINE))
|
||
(TYPE '";ERROR IN LINE "
|
||
BAD-LINE-NUMBER
|
||
'" OF "
|
||
USER-FUNCTION
|
||
'": ")
|
||
(MAPC '(LAMBDA (BAD-LINE-FORM) (UNPARSE-PRINT-FORM BAD-LINE-FORM)
|
||
(DPRINC '/ ))
|
||
(GETLINE (CADDR PROG-FRAME) BAD-LINE-NUMBER))
|
||
(TERPRI)
|
||
T)))
|
||
(TYPE '";COULDN'T EVALUATE ")
|
||
(UNPARSE-PRINT-FORM (CADDR START-FRAME))
|
||
(TYPE EOL '";BECAUSE " MESSAGE)
|
||
(OR :ERRBREAK :LISPBREAK (ERR 'ERRBREAK))
|
||
;;NO BREAKPOINT, CAUSE ERROR BACK TO TOP LEVEL.
|
||
(DTERPRI)
|
||
(BREAK-POINT NIL
|
||
NIL
|
||
START-FRAME
|
||
(COND (:ERRBREAK (EXPR-FUNCTION UNPARSE-PRINT-FORM))
|
||
((EXPR-FUNCTION DPRINC)))
|
||
(COND (:ERRBREAK 'LOGO-BREAK-LOOP)
|
||
('LISP-BREAK-LOOP))))))
|
||
|
||
(DEFUN ERROR-LINE-NUMBER (PROG-FRAME)
|
||
;;RETURNS THE LINE NUMBER CONTAINING THE FORM WHICH CAUSED THE ERROR IN THE
|
||
;;LOGO USER FUNCTION CONTAINED IN PROG-FRAME.
|
||
(LET
|
||
((LINE-FORM (CADDR (EVALFRAME (- (CADR PROG-FRAME))))))
|
||
;;LINE-FORM IS THE FORM DIRECTLY BENEATH PROG ON STACK, THAT IS, TOP LEVEL
|
||
;;FORM OF THE LINE.
|
||
(COND
|
||
((EQ (CAR LINE-FORM) 'PARSEMACRO) (CADR (CADDR LINE-FORM)))
|
||
;;IF ERROR CAUSED WITHIN PARSEMACRO, SIMPLY EXTRACT THE LINE NUMBER FROM
|
||
;;THE PARSEMACRO FORM. SINCE PARSE CLOBBERED IN, FORM IN PROG WON'T MATCH
|
||
;;FORM ON STACK ANYWAY.
|
||
((DO
|
||
((REST-PROG (CDDR (CADDR PROG-FRAME)) (CDR REST-PROG))
|
||
(BAD-LINE-NUMBER 0.)
|
||
(THIS-FORM))
|
||
((COND
|
||
((NUMBERP (SETQ THIS-FORM (CAR REST-PROG)))
|
||
;;NEXT LINE NUMBER.
|
||
(SETQ BAD-LINE-NUMBER THIS-FORM)
|
||
NIL)
|
||
;;FIND THE RIGHT FORM, RETURN BAD-LINE-NUMBER.
|
||
((EQ LINE-FORM THIS-FORM))
|
||
((NULL REST-PROG)
|
||
;;RAN OFF THE END OF THE PROG -- SOMETHING WRONG!
|
||
(PRINT
|
||
'"SYSTEM BUG -- ERROR-LINE-NUMBER COULDN'T FIND FORM")
|
||
;;STANDARD ERROR BREAK WON'T DO HERE, AS THIS IS CALLED BY IT, WOULD
|
||
;;LIKELY LEAD TO INFINITE RECURSION.
|
||
(LISP-BREAK-LOOP)))
|
||
BAD-LINE-NUMBER))))))
|
||
|
||
;;ERRBREAK A REMNANT OF OBSOLETE ERROR HANDLING CODE.
|
||
|
||
(DEFUN ERRBREAK ARGS (ERROR (ARG 2.) 'ERRBREAK 'FAIL-ACT))
|
||
|
||
[(OR ITS DEC10) (ARGS 'ERRBREAK '(NIL . 2.))]
|
||
|
||
(SETQ FAIL-ACT 'FAIL-ACT)
|
||
|
||
(DEFUN FAIL-ACT (ERRS)
|
||
[(OR ITS DEC10) (LOGO-ERROR)]
|
||
[MULTICS (COND ((EQ ERRS 'ERRBREAK) (LOGO-ERROR))
|
||
((LISP-ERROR (SUBSTR (CAADDR (ERRFRAME NIL)) 6.))))])
|
||
|
||
(DEFUN LOGO-ERROR NIL (LISP-ERROR (CAADDR (ERRFRAME NIL))))
|
||
|
||
(DEFUN LISP-ERROR (MESSAGE)
|
||
(LIST (STACK-HACK (EVALFRAME (CADR (ERRFRAME NIL))) MESSAGE)))
|
||
|
||
(SETQ UNBND-VRBL 'UNBND-VRBL)
|
||
|
||
(DEFUN UNBND-VRBL (UNBOUND-VARIABLE)
|
||
(LISP-ERROR (LIST (CAR UNBOUND-VARIABLE)
|
||
'"IS AN UNBOUND VARIABLE")))
|
||
|
||
(DEFUN UNDF-FNCTN (ERRS)
|
||
(LISP-ERROR (LIST (CAR ERRS)
|
||
'"IS AN UNDEFINED PROCEDURE")))
|
||
|
||
(SETQ UNDF-FNCTN 'UNDF-FNCTN)
|
||
|
||
(DEFUN WRNG-TYPE-ARG (ERRS)
|
||
(LET
|
||
((BAD-ARGUMENT (CAR ERRS))
|
||
(UNHAPPY-FUNCTION
|
||
(UNPARSE-FUNCTION-NAME (CAADDR (EVALFRAME (ERRORFRAME))))))
|
||
(LISP-ERROR
|
||
(COND ((EQ BAD-ARGUMENT NO-VALUE)
|
||
(LIST '"AN ARGUMENT TO"
|
||
UNHAPPY-FUNCTION
|
||
'"WAS SOMETHING THAT DIDN'T OUTPUT"))
|
||
((LIST '"THE INPUT"
|
||
BAD-ARGUMENT
|
||
'TO
|
||
UNHAPPY-FUNCTION
|
||
'"IS OF THE WRONG TYPE"))))))
|
||
|
||
(SETQ WRNG-TYPE-ARG 'WRNG-TYPE-ARG)
|
||
|
||
(DEFUN UNSEEN-GO-TAG (ERRS)
|
||
(LISP-ERROR
|
||
(COND
|
||
((EQ (CAR ERRS) 'FRAMEUP-BREAK)
|
||
'"YOU TRIED TO USE A BREAKPOINT FUNCTION BUT YOU'RE NOT IN A BREAKPOINT")
|
||
((LIST (CAR ERRS) '"IS AN UNDEFINED TAG")))))
|
||
|
||
(SETQ UNSEEN-GO-TAG 'UNSEEN-GO-TAG)
|
||
|
||
(DEFUN ERRORFRAME NIL (AND (ERRFRAME NIL) (CADR (ERRFRAME NIL))))
|
||
|
||
(DEFINE ERRSET (PARSE 1. 2.))
|
||
|
||
;;CHANGING THE NUMBER OF INPUTS TO A FUNCTION CAN CAUSE LINES TYPED PREVIOUSLY TO
|
||
;;NOW BE INCORRECTLY PARSED. THIS HANDLER ATTEMPTS TO RECOVER WHERE POSSIBLE BY
|
||
;;REPARSING THE LINE. NOTE THAT ONE CAN'T WIN IN GENERAL, AS SIDE EFFECTS DURING
|
||
;;PARTIAL EXECUTION OF A LINE CANNOT BE UNDONE. A SOMEWHAT BETTER VERSION OF THIS
|
||
;;MIGHT USE FRETURN TO RETURN THE RESULT OF A NOW-CORRECT LINE FROM A HIGHER FRAME
|
||
;;THAN THE FORM CURRENTLY UNDER EXECUTION; SAY, THE WHOLE LINE, OR THE PROG. A MORE
|
||
;;RADICAL SOLUTION WOULD BE TO MAINTAIN A SUPERPROCEDURE TREE WHICH WOULD REPARSE
|
||
;;ALL CALLS TO A FUNCTION IF TITLE CHANGES.
|
||
|
||
(DEFUN WRONG-NO-ARGS (ERRS)
|
||
(LET
|
||
((CULPRIT (CAAR ERRS)))
|
||
;;IF LOGO USER FUNCTION CAUSED THE ERROR, TRY REPARSING, ELSE GIVE UP.
|
||
(COND ((MEMQ CULPRIT :CONTENTS)
|
||
(DO ((PROG-FRAME (STACK-SEARCH (ERRFRAME NIL) 'PROG)
|
||
;;SEARCH FOR FRAME CONTAINING PROG.
|
||
(STACK-SEARCH ABOVE-PROG 'PROG))
|
||
(ABOVE-PROG)
|
||
(USER-FUNCTION)
|
||
(REPARSED-LINE))
|
||
((COND ((NULL PROG-FRAME) (LISP-ERROR (WNA ERRS)))
|
||
((MEMQ (SETQ USER-FUNCTION
|
||
(CAADDR (SETQ ABOVE-PROG
|
||
(EVALFRAME (CADR PROG-FRAME)))))
|
||
:CONTENTS)
|
||
(SETQ REPARSED-LINE
|
||
(RETRY-PARSE USER-FUNCTION
|
||
(CADDR PROG-FRAME)
|
||
(ERROR-LINE-NUMBER PROG-FRAME)))
|
||
T))
|
||
(COND (REPARSED-LINE) ((LISP-ERROR (WNA ERRS)))))))
|
||
((LISP-ERROR (WNA ERRS))))))
|
||
|
||
(DEFUN RETRY-PARSE (REPARSED-PROCEDURE PROG BAD-LINE-NUMBER)
|
||
(LET
|
||
((^W T) (NEXT-TAG NIL) (LAST-LINE NIL) (THIS-LINE NIL) (PARSED))
|
||
;;REPARSE THE LINE. ERRSET AS PARSE MAY GENERATE ERROR, IN WHICH CASE WE
|
||
;;LOSE. IF PARSE OCCURS SUCCESSFULLY, MODIFY PROCEDURE, AND RETURN THE
|
||
;;PARSED FORMS TO TRY AGAIN.
|
||
(SETQ
|
||
PARSED
|
||
(ERRSET (PARSELINE (PASS2 (UNPARSE-LOGO-LINE (GETLINE PROG
|
||
BAD-LINE-NUMBER)))
|
||
;;THE T MEANS JUST ERR IF PARSING ERROR, DON'T TRY TO
|
||
;;EDIT. SEE PARSELINE, REREAD-ERROR.
|
||
T)
|
||
NIL))
|
||
(COND ((NOT (ATOM PARSED))
|
||
;;ATOM PARSED INDICATES PARSING ERROR, LIKELY TOO FEW ARGUMENTS
|
||
;;STILL, SO NOT AN EDIT TITLE SCREW.
|
||
(SETQ ^W NIL PARSED (CAR PARSED))
|
||
;;ERRSET RETURNS A LIST OF THE RESULT IF NO ERROR.
|
||
(TYPE '";REPARSING LINE "
|
||
BAD-LINE-NUMBER
|
||
'" OF "
|
||
REPARSED-PROCEDURE
|
||
'" AS "
|
||
PARSED
|
||
EOL)
|
||
(ADDLINE PROG (APPEND (CONS BAD-LINE-NUMBER PARSED) NIL))
|
||
;;ADD A COPY AS LINE GETS MUNGED DURING PROCEDURE EDITING, AND MUST
|
||
;;RETURN A CLEAN COPY.
|
||
(LIST (CONS 'PROGN PARSED))))))
|
||
|
||
(DEFUN WNA (ERRS)
|
||
;;FIGURE OUT HOW MANY ARGUMENTS THE FUNCTION EXPECTED, AND PRINT OUT
|
||
;;APPROPRIATE ERROR MESSAGE.
|
||
(LET ((CULPRIT (CAAR ERRS)) (EXPECTED NIL))
|
||
(COND ((SETQ EXPECTED (ARGS CULPRIT))
|
||
;;ARGS PROPERTY. LSUBR OR SUBR.
|
||
(CCONS (UNPARSE-FUNCTION-NAME CULPRIT)
|
||
'" EXPECTED "
|
||
(COND ((NULL (CAR EXPECTED))
|
||
(LIST (CDR EXPECTED)
|
||
'" INPUTS"))
|
||
((LIST '" BETWEEN"
|
||
(CAR EXPECTED)
|
||
'" AND "
|
||
(CDR EXPECTED)
|
||
'" INPUTS")))))
|
||
((SETQ EXPECTED (GET CULPRIT 'EXPR))
|
||
(LIST (UNPARSE-FUNCTION-NAME CULPRIT)
|
||
'" EXPECTED"
|
||
(LENGTH (CADR EXPECTED))
|
||
'" INPUTS"))
|
||
;;CAN'T FIGURE OUT HOW MANY ARGUMENTS WANTED.
|
||
((LIST '"WRONG NUMBER OF INPUTS TO "
|
||
(UNPARSE-FUNCTION-NAME CULPRIT))))))
|
||
|
||
(SETQ WRNG-NO-ARGS 'WRONG-NO-ARGS)
|
||
|
||
(*RSET T)
|
||
|
||
;(SSTATUS INTERRUPT 18. 'FASLOADER)
|
||
|
||
(DEFUN FASLOADER (FILE)
|
||
;;REDEFINE AUTOMATIC FASLOADER FOR TRACE, GRIND, LAP, ETC. TO FASLOAD STUFF
|
||
;;FROM THE LISP OBARRAY. THEREFORE IT IS CALLABLE FROM LOGO.
|
||
;;;
|
||
;;ALSO, IT'S NICE IF AUTOMATIC FASLOADER IS TRANSPARENT TO CURRENT DEFAULT
|
||
;;FILENAME AND DIRECTORY.
|
||
(LET ((OBARRAY LISP-OBARRAY)
|
||
(READTABLE LISP-READTABLE)
|
||
(CRFILE (STATUS CRFILE))
|
||
(CRUNIT (CRUNIT)))
|
||
;;READTABLE REBOUND SO THAT CHARACTER READMACROS DEFINED BY FASLOADED
|
||
;;FILE WILL NOT AFFECT LOGO READTABLE. I.E. DOUBLE-QUOTE AND SQUARE
|
||
;;BRACKET MACROS DEFINED BY FILE DEFINE >.
|
||
[(OR ITS DEC10) (APPLY 'FASLOAD (CDR FILE))]
|
||
[MULTICS (LOAD (CDR FILE))]
|
||
(APPLY 'CRUNIT CRUNIT)
|
||
(APPLY 'SSTATUS (CONS 'CRFILE CRFILE))))
|
||
|
||
(SETQ *RSET-TRAP NIL)
|
||
|
||
;;RSET BREAK TURNED OFF. HENCE, EXECUTING (LISP) WILL NOT RESULT IN BREAK. RSET
|
||
;;SERVICES ERRORS THAT REACH THE TOPLEVEL.
|
||
;;;
|
||
|
||
(DECLARE (MACROS T))
|
||
|
||
;;MISCELLANEOUS SYSTEM DEBUGGING FEATURES.
|
||
|
||
[ITS (DEFPROP LOAD-TECO (LISPT FASL DSK /.TECO/.) AUTOLOAD)
|
||
(DEFPROP START-TECO (LISPT FASL DSK /.TECO/.) AUTOLOAD)
|
||
(DEFPROP MEV (STEPMM FASL DSK COMMON) AUTOLOAD)
|
||
(DEFUN TECO NIL (COND (TECO? (P)) ((SETQ TECO? T) (LOAD-TECO) (G))))
|
||
(SETQ TECO? NIL)]
|
||
|
||
;;;
|
||
;;THIS FUNCTION SHOULD BE USED TO REPORT BUGS IN LISP LOGO. IT RELIEVES THE NAIVE
|
||
;;USER ABOUT HAVING TO KNOW ABOUT :BUG IN DDT. IT WRITES A FILE BUG > ON LLOGO;
|
||
;;CONTAINING THE USER'S GRIPE.
|
||
|
||
[(OR ITS MULTICS) (DEFINE FEATURE (ABB BUG) FEXPR (COMPLAINT)
|
||
(LET
|
||
((^W T)
|
||
(^R T)
|
||
(CRUNIT (CRUNIT))
|
||
(CRFILE (STATUS CRFILE))
|
||
[ITS (JNAME (STATUS JNAME))])
|
||
(UWRITE [ITS DSK
|
||
LLOGO])
|
||
(PRINC COMPLAINT)
|
||
(TERPRI)
|
||
(UFILE [ITS BUG
|
||
>]
|
||
[MULTICS LLOGO
|
||
BUG])
|
||
[ITS (VALRET
|
||
(ATOMIZE
|
||
'":QMAIL BUG-LLOGO ILLOGO;BUG >"
|
||
EOL
|
||
JNAME
|
||
'"JP"))
|
||
(UKILL BUG > DSK LLOGO)]
|
||
[MULTICS (CLINE
|
||
"MAIL LLOGO.BUG HENRY ESG;DELETE LLOGO.BUG")]
|
||
(APPLY 'CRUNIT CRUNIT)
|
||
(APPLY 'SSTATUS (CONS 'CRFILE CRFILE)))
|
||
'";THANK YOU FOR YOUR PATIENCE.")]
|
||
|