;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;		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.")]