github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-03-27 02:24:15 +00:00
Code Issues Releases Wiki Activity

Fixed llogo.

Browse Source
This commit is contained in:
Eric Swenson
2018-09-25 22:38:42 -07:00
parent 2769e25f06
commit ddbf4d79db
3 changed files with 2066 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

776
src/llogo/error.2 Normal file
View File

@@ -0,0 +1,776 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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.")]