Google
 

Trailing-Edge - PDP-10 Archives - -
Click to see without markup as text/plain
There are no other files named in the archive.
00010	
00020	
00030	(DEFPROP TRACE 
00040	 (LAMBDA(L)
00050	  (PROG (G1 G2 T1 FN TCTRS OLST)
00060	   LP1  (COND ((NULL L) (RETURN OLST)))
00070		(SETQ T1 (SETQ FN (CAR L)))
00080		(SETQ L (CDR L))
00090	   LP2  (COND
00100		 ((OR (NULL (CDR T1)) (EQ (CADR T1) (QUOTE TRACE)))
00110		  (GO LP1))
00120		 ((MEMBER (CADR T1) (QUOTE (FEXPR EXPR SUBR FSUBR)))
00130		  (GO LP3))
00140		 (T (SETQ T1 (CDDR T1)) (GO LP2)))
00150	   LP3  (SETQ OLST (NCONC OLST (LIST FN)))
00160		(SETQ G1 (INTERN (GENSYM)))
00170		(RPLACD (CDDR (SETQ G2 (INTERN (GENSYM))))
00180			(LIST (CADR T1) (CADDR T1)))
00190		(RPLACD T1
00200			(NCONC (LIST (QUOTE TRACE)
00210				     (CONS G1 G2)
00220				     (QUOTE FEXPR)
00230				     (LIST (QUOTE LAMBDA)
00240					   (QUOTE (/-L))
00250					   (LIST
00260					    (QUOTE TRACE1)
00270					    (QUOTE /-L)
00280					    (LIST (QUOTE QUOTE) G1)
00290					    (LIST (QUOTE QUOTE) G2)
00300					    (LIST (QUOTE QUOTE) FN))))
00310			       (CDDDR T1)))
00320		(SET G1 0.)
00330		(SETQ TCTRS (GET (QUOTE TRACE) (QUOTE CNTRS)))
00340		(PUTPROP (QUOTE TRACE) (CONS G1 TCTRS) (QUOTE CNTRS))
00350		(GO LP1))) 
00360	FEXPR)
00370	
00380	(DEFPROP TRACE1 
00390	 (LAMBDA(%-ARGS %-CNTR %-FUN %-NAM)
00400	  (PROG (%-VAL)
00410		(SET %-CNTR (ADD1 (EVAL %-CNTR)))
00420		(PUTPROP %-NAM
00430			 (ADD1 (COND ((GET %-NAM (QUOTE TRACECNT))) (T 0.)))
00440			 (QUOTE TRACECNT))
00450		(COND
00460		 (TRACEFLAG
00470		  (PRINT (LIST (QUOTE ENTERING) (EVAL %-CNTR) %-NAM))))
00480		(COND ((GET %-FUN (QUOTE FEXPR)) (GO L4))
00490		      ((GET %-FUN (QUOTE FSUBR)) (GO L4))
00500		      (T (SETQ %-ARGS (EVAL (CONS (QUOTE LIST) %-ARGS)))))
00510		(COND (TRACEFLAG (PRIN1 %-ARGS)))
00520		(SETQ %-VAL (APPLY (QUOTE %-FUN) %-ARGS))
00530		(GO L4A)
00540	   L4   (COND (TRACEFLAG (PRIN1 %-ARGS)))
00550		(SETQ %-VAL (EVAL (CONS %-FUN %-ARGS)))
00560	   L4A  (COND
00570		 (TRACEFLAG (PRINT
00580			     (LIST (QUOTE LEAVING) (EVAL %-CNTR) %-NAM))
00590			    (PRIN1 %-VAL)))
00600		(SET %-CNTR (SUB1 (EVAL %-CNTR)))
00610		(RETURN %-VAL))) 
00620	EXPR)
00630	
00640	(DEFPROP UNTRACE 
00650	 (LAMBDA(L)
00660	  (PROG (FN OLST T1 T2)
00670	   LP1  (COND ((NULL L) (RETURN OLST)))
00680		(SETQ T1 (SETQ FN (CAR L)))
00690		(SETQ L (CDR L))
00700	   LP2  (COND ((NULL (CDR FN)) (GO LP1))
00710		      ((EQ (CADR FN) (QUOTE TRACE)) (GO LP3)))
00720		(SETQ FN (CDDR FN))
00730		(GO LP2)
00740	   LP3  (SETQ OLST (NCONC OLST (LIST T1)))
00750		(SETQ T1 (CADDR FN))
00760		(RPLACD FN (NCONC (CDDR (CDDR T1)) (CDDR (CDDDR FN))))
00770		(EVAL (LIST (QUOTE REMOB) (CDR T1)))
00780		(SETQ FN (GET (QUOTE TRACE) (QUOTE CNTRS)))
00790		(SETQ T2 NIL)
00800	   LP4  (COND ((NULL FN) (GO LP5))
00810		      ((EQ (CAR FN) (CAR T1)) (GO LP6)))
00820		(SETQ T2 (CONS (CAR FN) T2))
00830		(SETQ FN (CDR FN))
00840		(GO LP4)
00850	   LP6  (SETQ T2 (NCONC T2 (CDR FN)))
00860	   LP5  (PUTPROP (QUOTE TRACE) T2 (QUOTE CNTRS))
00870		(EVAL (LIST (QUOTE REMOB) (CAR T1)))
00880		(GO LP1))) 
00890	FEXPR)
00900	
00910	(DEFPROP RESET 
00920	 (LAMBDA NIL
00930	  (PROG (T1)
00940		(SETQ T1 (GET (QUOTE TRACE) (QUOTE CNTRS)))
00950	   LP1  (COND ((NULL T1) (RETURN NIL)))
00960		(SET (CAR T1) 0.)
00970		(SETQ T1 (CDR T1))
00980		(GO LP1))) 
00990	EXPR)
01000	
01010	(DEFPROP TRACET 
01020	 (LAMBDA NIL
01030	  (PROG NIL
01040		(PUTPROP (QUOTE %TC1)
01050			 (GET (QUOTE SETQ) (QUOTE FSUBR))
01060			 (QUOTE FSUBR))
01070		(PUTPROP (QUOTE %TC2)
01080			 (GET (QUOTE SET) (QUOTE SUBR))
01090			 (QUOTE SUBR))
01100		(DEFPROP SETQ
01110			 (LAMBDA(%-L)
01120			  (PROG (%-SV)
01130				(%TC1 %-SV (EVAL (CONS (QUOTE %TC1) %-L)))
01140				(COND
01150				 ((NOT (MEMBER (CAR %-L) %TCL))
01160				  (RETURN %-SV)))
01170				(PRINT (LIST (QUOTE SETQ) (CAR %-L) %-SV))
01180				(TERPRI)
01190				(RETURN %-SV)))
01200	 		 FEXPR)
01210		(%TC1 %TCL NIL)
01220		(DEFPROP SET
01230			 (LAMBDA(%-L %-K)
01240			  (PROG NIL
01250				(%TC2 %-L %-K)
01260				(COND
01270				 ((NOT (MEMBER %-L %TCL)) (RETURN %-K)))
01280				(PRINT (LIST (QUOTE SET) %-L %-K))
01290				(TERPRI)
01300				(RETURN %-K)))
01310	 		 EXPR))) 
01320	EXPR)
01330	
01340	(DEFPROP SLST 
01350	 (LAMBDA (L) (%TC1 %TCL (NCONC %TCL L))) 
01360	FEXPR)
01370	
01380	(DEFPROP USLST 
01390	 (LAMBDA(L)
01400	  (PROG (OLST)
01410	   LP1  (COND ((NULL %TCL) (RETURN (%TC1 %TCL OLST)))
01420		      ((MEMBER (CAR %TCL) L) (%TC1 %TCL (CDR %TCL)))
01430		      (T (%TC1 OLST (CONS (CAR %TCL) OLST))
01440			 (%TC1 %TCL (CDR %TCL))))
01450		(GO LP1))) 
01460	FEXPR)
01470	
01480	(DEFPROP UNTRACET 
01490	 (LAMBDA NIL
01500	  (PROG NIL
01510		(REMPROP (QUOTE SETQ) (QUOTE FEXPR))
01520		(REMPROP (QUOTE SET) (QUOTE EXPR))
01530		(REMOB %TC1)
01540		(REMOB %TC2)
01550		(REMOB %TCL))) 
01560	EXPR)
01570	
01580	(DEFPROP TRACEZERO 
01590	 (LAMBDA NIL
01600	  (MAPC (FUNCTION
01610		 (LAMBDA(A)
01620		  (COND
01630		   (A
01640		    (MAPC (FUNCTION
01650			   (LAMBDA (B) (REMPROP B (QUOTE TRACECNT))))
01660	 		  A)))))
01670	        OBLIST)) 
01680	EXPR)
01690	
01700	(DEFPROP TRACETALLY 
01710	 (LAMBDA NIL
01720	  (MAPC (FUNCTION
01730		 (LAMBDA(A)
01740		  (COND
01750		   (A
01760		    (MAPC (FUNCTION
01770			   (LAMBDA(B)
01780			    (COND
01790			     ((GET B (QUOTE TRACECNT))
01800			      (PRINT B)
01810			      (TYO 9.)
01820			      (TYO 61.)
01830			      (PRINC (GET B (QUOTE TRACECNT)))))))
01840	 		  A)))))
01850	        OBLIST)) 
01860	EXPR)
01870	
01880	
01890	(SETQ TRACEFLAG T)	 NEEDS TO BE DECLARED SPECIAL, IF COMPILING.