perm filename BREAK.LSP[RUT,LSP] blob sn#343766 filedate 1978-03-22 generic text, type T, neo UTF8
(DECLARE (SPECIAL BROKENFNS TRACEDFNS TRACEVFNS UNBREAKABLEFNS BKFNLIST
		  UPFINDFLG #%INDENT LASTWORD)
	 (NOCALL SAVEDEF ATOMLISTP BREAKIN0 UNBREAKIN BREAK0A CHNGNM CHNM1
		 RESTORE PACK-IN)
	 (CALL %PRINFN))

(DEFPROP BREAK0
 (LAMBDA (FN WHEN COM)
  (PROG (FN1 FN2)
	(COND
	 [(CONSP FN)
	  (RETURN (COND [(NOT (EQ (CADR FN) 'IN))
			 (MAPCAR (FUNCTION (LAMBDA (FN) (BREAK0 FN WHEN COM)))
				 FN)]
			[T (COND [(ATOM (SETQ FN1 (CAR FN)))
				  (SETQ FN1 (LIST FN1))])
			   (MAPCAN (FUNCTION
				    (LAMBDA (FN2)
				     (MAPCAR (FUNCTION
					      (LAMBDA (FN1)
					       (BREAK0A FN1 FN2 WHEN COM)))
					     FN1)))
				   (COND [(ATOM (SETQ FN2 (CADDR FN)))
					  (LIST FN2)]
					 [T FN2]))]))]
	 [(NULL (SETQ FN1 (GETL FN '(EXPR FEXPR SUBR FSUBR LSUBR MACRO))))
	  (MSG -1. FN " is not a breakable function." T)
	  (RETURN (CONS FN '(?)))]
	 [(GET FN 'TRACE)
	  (SETQ BROKENFNS (REMOVE FN BROKENFNS))
	  (SETQ TRACEDFNS (REMOVE FN TRACEDFNS))
	  (COND [(EQ (CAR (SETQ FN2 (CAR (CDDADR FN1)))) 'BREAK1)
		 (RPLACA (CDDR FN2) WHEN)
		 (GO END)]
		[T (APPLY# 'UNBREAK (LIST FN)) (RETURN (BREAK0 FN WHEN COM))])])
	(COND [(MEMQ FN UNBREAKABLEFNS)
	       (MSG -1. FN " unbreakable unless IN something." T)
	       (RETURN (CONS FN '(?)))])
	(SETQ FN1 (SAVEDEF FN FN1))
	(REMPROP FN (CAR FN1))
	(PUTPROP FN 
		 (LIST (CAADR FN1)
		       (CADADR FN1)
		       (SETQ FN2
			     (LIST 'BREAK1
				   (CONS 'QUOTE (CDDADR FN1))
				   WHEN 
				   (LIST 'QUOTE FN)
				   NIL 
				   NIL)))
		 (CAR FN1))
    END (RPLACA (CDDDDR FN2)
		(AND COM 
		     [LIST 'QUOTE
			   (COND [(EQ (CADR COM) '//BREAK1)
				  (RPLACA (CDR COM)
					  (CONS '?= (CONSP (CADADR FN1))))
				  COM]
				 [COM])]))
	(SET BKFNLIST (CONS FN (EVAL BKFNLIST)))
	(RETURN FN)))
 EXPR)

(DEFPROP SAVEDEF
 (LAMBDA (FN DEF)
  (PROG (GS ARGS)
     L0 (COND [(CDDDR (SETQ GS (INTERN (GENSYM)))) (GO L0)])
	(NCONC (CDR GS)
	       (LIST (COND [(EQ (CAR DEF) 'MACRO) 'FEXPR] [(CAR DEF)])
		     (CADR DEF)))
	(PUTPROP GS (CONS FN (CAR DEF)) 'FUNTYPE)
	(PUTPROP GS '(T T NIL NIL) 'ERXACTION)
	(PUTPROP FN '(NIL NIL T T) 'ERXACTION)
     L1 (COND [(MEMQ (CAR DEF) '(FSUBR SUBR))
	       (COND [(SETQ ARGS (GET FN 'ARGS)) (GO L2)])
	       (MSG 0. FN " argument list? ")
	       (COND [(AND [SETQ ARGS (READ)] [ATOM ARGS])
		      (MSG 0. "Should be a list.")
		      (GO L1)]
		     [(NOT (ATOMLISTP ARGS))
		      (MSG 0. "Should be a list of atomic arguments.")
		      (GO L1)]
		     [(AND [EQ (CAR DEF) 'FSUBR] [OR [NULL ARGS] [CDR ARGS]])
		      (MSG 0. "FSUBR -- Takes exactly one argument.")
		      (GO L1)])
	       (PUTPROP FN ARGS 'ARGS)]
	      [(EQ (CAR DEF) 'LSUBR) (SETQ ARGS 'N?)]
	      [(AND [ATOM (SETQ ARGS (CADADR DEF))]
		    ARGS 
		    [RPLACA (CDADR DEF) (NCONS (CADADR DEF))]
		    [PUTPROP GS T 'LEXPR])])
     L2 (PUTPROP FN (CONS NIL GS) 'TRACE)
	(RETURN (LIST (COND [(MEMQ (CAR DEF) '(SUBR EXPR LSUBR)) 'EXPR]
			    [(EQ (CAR DEF) 'MACRO) 'MACRO]
			    ['FEXPR])
		      (LIST 'LAMBDA
			    ARGS 
			    (LIST 'BRKAPPLY
				  (LIST 'QUOTE GS)
				  (COND [(EQ (CAR DEF) 'LSUBR) (LIST 'LXPD 'N?)]
					[(AND ARGS [ATOM ARGS])
					 (LIST 'QUOTE (NCONS ARGS))]
					[(MEMQ (CAR DEF) '(SUBR EXPR))
					 (LIST 'QUOTE ARGS)]
					[T (CAR ARGS)])))))))
 EXPR)

(DEFPROP ATOMLISTP
 (LAMBDA (LL)
  (PROG NIL
     LP (COND [(NULL LL) (RETURN T)]
	      [(ATOM (CAR LL)) (SETQ LL (CDR LL)) (GO LP)])))
 EXPR)

(DEFPROP BRKAPPLY
 (LAMBDA (#%FN%# #%ARGS%#) (EVAL (CONS #%FN%# #%ARGS%#)))
 EXPR)

(DEFPROP BREAK
 (LAMBDA (FNS)
  (PROG (VAL FN)
	(OR FNS [SETQ FNS (LIST LASTWORD)])
     LP (SETQ VAL
	      (CONS (COND [(NULL FNS) (RETURN VAL)]
			  [(ATOM (SETQ FN (CAR FNS)))
			   (SETQ FN (BREAK0 FN T NIL))
			   (AND [ATOM FN] [SETQ LASTWORD FN])
			   FN]
			  [(EQ (CADR FN) 'IN) (BREAK0 FN T NIL)]
			  [(CDR FN) (BREAK0 (CAR FN) (CADR FN) (CDDR FN))]
			  [T (CONS FN '(?))])
		    VAL))
	(SETQ FNS (CDR FNS))
	(GO LP)))
 FEXPR)

(DEFPROP TRACE
 (LAMBDA (FNS)
  (PROG (VAL FN BKFNLIST)
	(OR FNS [SETQ FNS (LIST LASTWORD)])
	(SETQ BKFNLIST 'TRACEDFNS)
     LP (SETQ VAL
	      (CONS (COND [(NULL FNS) (RETURN VAL)]
			  [(ATOM (SETQ FN (CAR FNS)))
			   (SETQ FN
				 (BREAK0 FN 
					 T 
					 (LIST '(TRACE) '//BREAK1 '(UNTRACE))))
			   (AND [ATOM FN] [SETQ LASTWORD FN])
			   FN]
			  [(EQ (CADR FN) 'IN)
			   (BREAK0 FN T (LIST '(TRACE) '//BREAK1 '(UNTRACE)))]
			  [T (BREAK0 (CAR FN)
				     (COND [(CDR FN) (CADR FN)] [T])
				     (LIST '(TRACE)
					   (COND [(CDDR FN)
						  (CONS '?= (CDDR FN))]
						 [T '//BREAK1])
					   '(UNTRACE)))])
		    VAL))
	(SETQ FNS (CDR FNS))
	(GO LP)))
 FEXPR)

(DEFV TRACE NIL)

(DEFPROP BREAKIN
 (LAMBDA (X)
  (BREAKIN0 (CAR X)
	    (COND [(SETQ X (CDR X)) (CAR X)] ['(BEFORE TTY:)])
	    (COND [(AND X [SETQ X (CDR X)]) (CAR X)] [T])
	    (AND X [LIST 'QUOTE (CDR X)])))
 FEXPR)

(DEFPROP BREAKIN0
 (LAMBDA (FN WHERE WHEN BKINCOMS)
  (PROG (FNDEF W MESS)
	(COND [(SETQ FNDEF
		     (GETL (COND [(SETQ W (GET FN 'TRACE)) (CDR W)] [FN])
			   '(EXPR FEXPR MACRO)))
	       (SETQ FNDEF (CADR FNDEF))]
	      [T (MSG -1. FN " can't be broken into." T)
		 (RETURN (CONS FN '(?)))])
	(COND [(CONSP (CAR WHERE))
	       (SETQ W (CDR WHERE))
	       (SETQ WHERE (CAR WHERE))]
	      [T (SETQ W NIL)])
   LOOP (OR [MEMQ (CAR WHERE) '(AROUND BEFORE AFTER)]
	    [PROGN (PRINT (CAR WHERE)) (PRINC '"  ?") (TERPRI) (GO NEXT)])
	(SETQ MESS
	      (LIST 'BREAK1
		    (COND [(EQ (CAR WHERE) 'AROUND) ''*])
		    WHEN 
		    (LIST 'QUOTE (LIST FN WHERE))
		    BKINCOMS 
		    NIL))
	(COND [(ATOM (ERRSET (EDITE FNDEF 
				    (LIST (CONS 'LC (CDR WHERE))
					  (LIST (SELECTQ [CAR WHERE]
							 [AFTER 'A]
							 [BEFORE 'B]
							 [AROUND 'MBD]
							 [CAR WHERE])
						MESS))
				    NIL)
			     ERRORX))
	       (MSG -1. (CDR WHERE) " not found in " FN T)]
	      [T (PUTPROP FN T 'BROKEN-IN)
		 (SETQ BROKENFNS (CONS FN (REMOVE FN BROKENFNS)))])
   NEXT (COND [W (SETQ WHERE (CAR W)) (SETQ W (CDR W)) (GO LOOP)])
	(RETURN FN)))
 EXPR)

(DEFPROP UNBREAKIN
 (LAMBDA (FN)
  (PROG (W UPFINDFLG)
	(SETQ UPFINDFLG T)
	(COND [(SETQ W (GET FN 'TRACE)) (SETQ W (CDR W))] [(SETQ W FN)])
	(COND [(SETQ W (GETL W '(EXPR FEXPR MACRO))) (SETQ W (CADR W))]
	      [(RETURN (CONS FN '(?)))])
	(EDITE W 
	       '((LPQ F 
		      BREAK1 
		      (COMS (SELECTQ [## 4. 2. 2. 1.]
				     [AROUND '(XTR 2. 2.)]
				     [(AFTER BEFORE) 'DELETE]
				     NIL))))
	       NIL)
	(RETURN FN)))
 EXPR)

(DEFPROP BREAK0A
 (LAMBDA (BFN INFN WHEN COMS)
  (COND [(ATOM (SETQ BFN (CHNGNM INFN BFN NIL))) (BREAK0 BFN WHEN COMS)]
	[T BFN]))
 EXPR)

(DEFPROP CHNGNM
 (LAMBDA (FN OLDN FLG)
  (PROG (DEF NEWN X Y Z)
	(COND [(NULL (SETQ DEF
			   (GETL (COND [(SETQ Z (GET FN 'TRACE)) (CDR Z)] [FN])
				 '(EXPR FEXPR MACRO))))
	       (MSG -1. FN " can't be broken into." T)
	       (RETURN (CONS FN '(?)))])
	(SETQ NEWN (PACK-IN (LIST OLDN 'IN FN)))
	(COND [FLG (REMPROP NEWN (CAR DEF))
		   (COND [(SETQ Z (REMOVE OLDN (GET FN 'NAMESCHANGED)))
			  (PUTPROP FN Z 'NAMESCHANGED)]
			 [(REMPROP FN 'NAMESCHANGED)])
		   (REMPROP NEWN 'ALIAS)
		   (SETQ Y OLDN)
		   (SETQ X NEWN)]
	      [T (SETQ Y NEWN)
		 (SETQ X
		       (COND [(MEMQ OLDN (GET FN 'NAMESCHANGED)) NEWN] [T OLDN])
		  )])
	(UNMACEXPAND (CADR DEF))
	(COND [(NULL (CHNM1 (CADR DEF) X Y))
	       (MSG -1. X " not found in " FN T)
	       (RETURN (CONS FN '(?)))])
	(COND [(NULL FLG)
	       (PUTPROP NEWN 
			(CADR (SETQ Z
				    (GETL OLDN 
					  '(EXPR FEXPR SUBR FSUBR LSUBR MACRO)))
			 )
			(CAR Z))
	       (COND [(NOT (MEMQ OLDN (SETQ Z (GET FN 'NAMESCHANGED))))
		      (PUTPROP FN (CONS OLDN Z) 'NAMESCHANGED)])
	       (PUTPROP NEWN (CONS FN OLDN) 'ALIAS)
	       (AND [SETQ DEF (GET OLDN 'ARGS)] [PUTPROP NEWN DEF 'ARGS])])
	(RETURN Y)))
 EXPR)

(DEFPROP UNBREAK
 (LAMBDA (X)
  (PROG (Y)
	(COND [(NULL X) (SETQ X (EVAL BKFNLIST)) (SET BKFNLIST NIL)]
	      [(AND [EQ (CAR X) T] [SETQ Y (EVAL BKFNLIST)])
	       (RPLACA X (CAR Y))
	       (SET BKFNLIST (CDR Y))])
	(RETURN (MAPCAR (FUNCTION UNBREAK0) X))))
 FEXPR)

(DEFPROP UNTRACE
 (LAMBDA (X)
  (PROG (BKFNLIST)
	(SETQ BKFNLIST 'TRACEDFNS)
	(RETURN (APPLY# 'UNBREAK X))))
 FEXPR)

(DEFPROP UNBREAK!
 (LAMBDA (X)
  (AND [EQ X (UNBREAK0 X)] [TTYMSG -1. X " is being unbroken." T])
  (MAPC (FUNCTION
	 (LAMBDA (Y)
	  (UNBREAK0 (SETQ Y (LIST Y 'IN X)))
	  (TTYMSG -1. Y " is being unbroken." T)))
	(GET X 'NAMESCHANGED)))
 EXPR)

(DEFPROP UNBREAK0
 (LAMBDA (FN)
  (PROG (X ALIAS)
	(SETQ BROKENFNS (DREMOVE (SETQ FN (PACK-IN FN)) BROKENFNS))
	(SETQ TRACEDFNS (DREMOVE FN TRACEDFNS))
	(SETQ X (RESTORE FN 'TRACE))
	(COND [(GET FN 'BROKEN-IN)
	       (SETQ X (UNBREAKIN FN))
	       (REMPROP FN 'BROKEN-IN)])
	(AND [SETQ ALIAS (GET FN 'ALIAS)] [CHNGNM (CAR ALIAS) (CDR ALIAS) T])
	(RETURN X)))
 EXPR)

(DEFPROP RESTORE
 (LAMBDA (FN P)
  (PROG (Y Z TYPE)
	(RETURN
	 (COND
	  [(SETQ Y (GET FN P))
	   (SETQ Y (CDR Y))
	   (COND [(AND [SETQ Z
			     (GET FN 
				  (SELECTQ [SETQ TYPE (CDR (GET Y 'FUNTYPE))]
					   [(EXPR SUBR LSUBR) 'EXPR]
					   [(FEXPR FSUBR) 'FEXPR]
					   'MACRO))]
		       [EQ (CAADDR Z) 'BREAK1])
		  (PUTPROP FN 
			   (SETQ Z (GET Y (SELECTQ TYPE [MACRO 'FEXPR] TYPE)))
			   TYPE)
		  (COND [(GET Y 'LEXPR) (RPLACA (CDR Z) (CAADR Z))]
			[(MEMQ TYPE '(LSUBR SUBR)) (REMPROP FN 'EXPR)]
			[(MEMQ TYPE '(FSUBR MACRO)) (REMPROP FN 'FEXPR)])])
	   (EVAL (LIST 'REMOB Y))
	   (REMPROP FN 'ERXACTION)
	   (REMPROP FN P)
	   FN]
	  [(CONS FN '(not broken))]))))
 EXPR)

(DEFPROP PACK-IN
 (LAMBDA (X)
  (COND [(ATOM X) X]
	[(EQ (CADR X) 'IN)
	 (READLIST (NCONC (AEXPLODE (CAR X))
			  (NCONC (AEXPLODE '-IN-) (AEXPLODE (CADDR X)))))]
	[(PRINT (CONS X '(?))) (ERR NIL)]))
 EXPR)

(DEFPROP TRACEV
 (LAMBDA (L)
  (COND [(NULL TRACEVFNS)
	 (DEFP SETQ %TRSETQ (FSUBR FEXPR))
	 (DEFP SET %TRSET (SUBR EXPR))])
  (SETQ TRACEVFNS (NCONC (REVERSE L) TRACEVFNS))
  L)
 FEXPR)

(DEFPROP UNTRACEV
 (LAMBDA (L)
  (COND [(NULL L) (SETQ L (APPEND TRACEVFNS NIL))]
	[(AND TRACEVFNS [EQ (CAR L) T]) (RPLACA L (CAR TRACEVFNS))])
  (PROG1 (MAPCAR (FUNCTION
		  (LAMBDA (X)
		   (COND [(MEMB X TRACEVFNS)
			  (SETQ TRACEVFNS (DREMOVE X TRACEVFNS))
			  X]
			 [T (CONS X '(not TRACEVed))])))
		 L)
	 (COND [(NULL TRACEVFNS) (DEFP SETQ BKSETQ FSUBR) (DEFP SET BKSET SUBR)]
	  )))
 FEXPR)

(DEFPROP %TRSETQ (LAMBDA (P) (%TRSET (CAR P) (EVAL (CADR P)))) FEXPR)

(DEFPROP %TRSET
 (LAMBDA (A V)
  (COND [(MEMB A TRACEVFNS) (BKPOS #%INDENT) (MSG "Set " A " to ") (%PRINFN V)])
  (SET A V))
 EXPR)

(DEFP BKSETQ SETQ FSUBR)

(DEFP BKSET SET SUBR)

(DEFV BROKENFNS NIL)

(DEFV TRACEDFNS NIL)

(DEFV TRACEVFNS NIL)

(DEFV BKFNLIST BROKENFNS)

(DEFV UNBREAKABLEFNS (BREAK1 //BREAK1 %UNTRACE LXPD BRKAPPLY BKSETQ BKSET
		      QUOTE))

(NOCOMPILE
(DEFV BREAKFNS ((DECLARE (SPECIAL BROKENFNS TRACEDFNS TRACEVFNS 
		UNBREAKABLEFNS BKFNLIST UPFINDFLG #%INDENT LASTWORD) 
		(NOCALL SAVEDEF ATOMLISTP BREAKIN0 UNBREAKIN BREAK0A CHNGNM 
		CHNM1 RESTORE PACK-IN) (CALL %PRINFN)) BREAK0 SAVEDEF 
		ATOMLISTP BRKAPPLY BREAK TRACE BREAKIN BREAKIN0 UNBREAKIN 
		BREAK0A CHNGNM UNBREAK UNTRACE UNBREAK! UNBREAK0 RESTORE 
		PACK-IN TRACEV UNTRACEV %TRSETQ %TRSET (DEFP BKSETQ SETQ 
		FSUBR) (DEFP BKSET SET SUBR) (V: (BROKENFNS NIL) (TRACEDFNS 
		NIL) (TRACEVFNS NIL) (BKFNLIST BROKENFNS) UNBREAKABLEFNS)))
)