Google
 

Trailing-Edge - PDP-10 Archives - -
Click to see without markup as text/plain
There are no other files named in the archive.

(DEFPROP TRACEFNS 
 (NIL TRACE TRACE1 UNTRACE RESET TRACET SLST USLST UNTRACET) 
VALUE)

(DEFPROP TRACE 
 (LAMBDA(L)
  (PROG (G1 G2 T1 FN TCTRS OLST)
   LP1  (COND ((NULL L) (RETURN OLST)))
	(SETQ T1 (SETQ FN (CAR L)))
	(SETQ L (CDR L))
   LP2  (COND ((OR (NULL (CDR T1)) (EQ (CADR T1) (QUOTE TRACE))) (GO LP1))
	      ((MEMBER (CADR T1) (QUOTE (FEXPR EXPR SUBR FSUBR))) (GO LP3))
	      (T (SETQ T1 (CDDR T1)) (GO LP2)))
   LP3  (SETQ OLST (NCONC OLST (LIST FN)))
	(SETQ G1 (INTERN (GENSYM)))
	(RPLACD (CDDR (SETQ G2 (INTERN (GENSYM)))) (LIST (CADR T1) (CADDR T1)))
	(RPLACD T1
		(NCONC (LIST (QUOTE TRACE)
			     (CONS G1 G2)
			     (QUOTE FEXPR)
			     (LIST (QUOTE LAMBDA)
				   (QUOTE (/-L))
				   (LIST (QUOTE TRACE1)
					 (QUOTE /-L)
					 (LIST (QUOTE QUOTE) G1)
					 (LIST (QUOTE QUOTE) G2)
					 (LIST (QUOTE QUOTE) FN))))
		       (CDDDR T1)))
	(SET G1 0)
	(SETQ TCTRS (GET (QUOTE TRACE) (QUOTE CNTRS)))
	(PUTPROP (QUOTE TRACE) (CONS G1 TCTRS) (QUOTE CNTRS))
	(GO LP1))) 
FEXPR)

(DEFPROP TRACE1 
 (LAMBDA(%-ARGS %-CNTR %-FUN %-NAM)
  (PROG (%-VAL)
	(SET %-CNTR (ADD1 (EVAL %-CNTR)))
	(PRINT (LIST (QUOTE ENTERING) (EVAL %-CNTR) %-NAM))
	(COND ((GET %-FUN (QUOTE FEXPR)) (PRIN1 %-ARGS) (GO L4))
	      ((GET %-FUN (QUOTE FSUBR)) (PRIN1 %-ARGS) (GO L4))
	      (T (PRIN1 (SETQ %-ARGS (EVAL (CONS (QUOTE LIST) %-ARGS))))))
	(SETQ %-VAL (APPLY (QUOTE %-FUN) %-ARGS))
	(GO L4A)
   L4   (SETQ %-VAL (EVAL (CONS %-FUN %-ARGS)))
   L4A  (PRINT (LIST (QUOTE LEAVING) (EVAL %-CNTR) %-NAM))
	(PRIN1 %-VAL)
	(SET %-CNTR (SUB1 (EVAL %-CNTR)))
	(RETURN %-VAL))) 
EXPR)

(DEFPROP UNTRACE 
 (LAMBDA(L)
  (PROG (FN OLST T1 T2)
   LP1  (COND ((NULL L) (RETURN OLST)))
	(SETQ T1 (SETQ FN (CAR L)))
	(SETQ L (CDR L))
   LP2  (COND ((NULL (CDR FN)) (GO LP1)) ((EQ (CADR FN) (QUOTE TRACE)) (GO LP3)))
	(SETQ FN (CDDR FN))
	(GO LP2)
   LP3  (SETQ OLST (NCONC OLST (LIST T1)))
	(SETQ T1 (CADDR FN))
	(RPLACD FN (NCONC (CDDR (CDDR T1)) (CDDR (CDDDR FN))))
	(EVAL (LIST (QUOTE REMOB) (CDR T1)))
	(SETQ FN (GET (QUOTE TRACE) (QUOTE CNTRS)))
	(SETQ T2 NIL)
   LP4  (COND ((NULL FN) (GO LP5)) ((EQ (CAR FN) (CAR T1)) (GO LP6)))
	(SETQ T2 (CONS (CAR FN) T2))
	(SETQ FN (CDR FN))
	(GO LP4)
   LP6  (SETQ T2 (NCONC T2 (CDR FN)))
   LP5  (PUTPROP (QUOTE TRACE) T2 (QUOTE CNTRS))
	(EVAL (LIST (QUOTE REMOB) (CAR T1)))
	(GO LP1))) 
FEXPR)

(DEFPROP RESET 
 (LAMBDA NIL
  (PROG (T1)
	(SETQ T1 (GET (QUOTE TRACE) (QUOTE CNTRS)))
   LP1  (COND ((NULL T1) (RETURN NIL)))
	(SET (CAR T1) 0)
	(SETQ T1 (CDR T1))
	(GO LP1))) 
EXPR)

(DEFPROP TRACET 
 (LAMBDA NIL
  (PROG NIL
	(PUTPROP (QUOTE %TC1) (GET (QUOTE SETQ) (QUOTE FSUBR)) (QUOTE FSUBR))
	(PUTPROP (QUOTE %TC2) (GET (QUOTE SET) (QUOTE SUBR)) (QUOTE SUBR))
	(DEFPROP SETQ
		 (LAMBDA(%-L)
		  (PROG (%-SV)
			(%TC1 %-SV (EVAL (CONS (QUOTE %TC1) %-L)))
			(COND ((NOT (MEMBER (CAR %-L) %TCL)) (RETURN %-SV)))
			(PRINT (LIST (QUOTE SETQ) (CAR %-L) %-SV))
			(TERPRI)
			(RETURN %-SV)))
 		 FEXPR)
	(%TC1 %TCL NIL)
	(DEFPROP SET
		 (LAMBDA(%-L %-K)
		  (PROG NIL
			(%TC2 %-L %-K)
			(COND ((NOT (MEMBER %-L %TCL)) (RETURN %-K)))
			(PRINT (LIST (QUOTE SET) %-L %-K))
			(TERPRI)
			(RETURN %-K)))
 		 EXPR))) 
EXPR)

(DEFPROP SLST 
 (LAMBDA (L) (%TC1 %TCL (NCONC %TCL L))) 
FEXPR)

(DEFPROP USLST 
 (LAMBDA(L)
  (PROG (OLST)
   LP1  (COND ((NULL %TCL) (RETURN (%TC1 %TCL OLST)))
	      ((MEMBER (CAR %TCL) L) (%TC1 %TCL (CDR %TCL)))
	      (T (%TC1 OLST (CONS (CAR %TCL) OLST)) (%TC1 %TCL (CDR %TCL))))
	(GO LP1))) 
FEXPR)

(DEFPROP UNTRACET 
 (LAMBDA NIL
  (PROG NIL
	(REMPROP (QUOTE SETQ) (QUOTE FEXPR))
	(REMPROP (QUOTE SET) (QUOTE EXPR))
	(REMOB %TC1)
	(REMOB %TC2)
	(REMOB %TCL))) 
EXPR)