(FILECREATED "18-JUL-83 21:55:09" <NEWLISP>WEDIT.;2 28788  

      changes to:  (VARS WEDITCOMS)
		   (MACROS CFOBF)

      previous date: "11-JUL-83 01:48:21" <NEWLISP>WEDIT.;1)


(* Copyright (c) 1982, 1983 by Xerox Corporation)

(PRETTYCOMPRINT WEDITCOMS)

(RPAQQ WEDITCOMS [(VARS EDITOPS MAXLOOP (EDITRACEFN)
			(UPFINDFLG T)
			MAXLEVEL FINDFLAG (EDITQUIETFLG))
	[INITVARS (EDITSMASHUSERFN)
		  (EDITEMBEDTOKEN (QUOTE &))
		  (EDITUSERFN)
		  (CHANGESARRAY)
		  (EDITUNSAVEBLOCKFLG T)
		  (EDITLOADFNSFLG (QUOTE (T]
	(INITVARS (EDITMACROS)
		  (USERMACROS))
	(ADDVARS (HISTORYCOMS ?? REDO REPEAT FIX USE ... NAME RETRIEVE DO !N !E !F TYPE-AHEAD  
			      BUFS ;)
		 (DONTSAVEHISTORYCOMS SAVE P ? PP PP* E ;)
		 (EDITCOMSA OK STOP SAVE TTY: E ? PP PP* PPV P ↑ !0 MARK UNDO !UNDO TEST UNBLOCK ← \ 
			    \P ←← F BF UP DELETE NX BK !NX ?? REDO REPEAT FIX USE NAME RETRIEVE DO !N 
			    !E !F TYPE-AHEAD)
		 (EDITCOMSL S R R1 RC RC1 E I N P F FS F= ORF BF NTH IF RI RO LI LO BI BO M NX BK ORR 
			    MBD XTR THRU TO A B : AFTER BEFORE MV LP LPQ LC LCL ← BELOW SW BIND COMS 
			    ORIGINAL INSERT REPLACE CHANGE DELETE EMBED SURROUND MOVE EXTRACT SWITCH 
			    ?? REDO REPEAT FIX USE NAME RETRIEVE DO MARK \))
	(USERMACROS CAP LOWER RAISE 2ND 3RD %%F %% NEX REPACK * >* SHOW EXAM PP*)
	(* * control chars for moving around in the editor)
	(FNS SETTERMCHARS INTCHECK CHARMACRO)
	(INITVARS (EDITCHARACTERS))
	(VARS NEGATIONS)
	(USERMACROS 2P NXP BKP -1P)
	(ADDVARS (COMPACTHISTORYCOMS 2P NXP BKP -1P))
	(DECLARE: DONTCOPY (MACROS CFOBF))
	(BLOCKS (SETTERMCHARS SETTERMCHARS INTCHECK (NOLINKFNS . T)
			      (GLOBALVARS EDITRDTBL))
		(NIL CHARMACRO (LOCALVARS . T)))
	(* * macros for calling editor)
	(USERMACROS EF EV EP)
	(ADDVARS (DONTSAVEHISTORYCOMS EF EV EP))
	(FNS FIRSTATOM)
	(BLOCKS (NIL FIRSTATOM (LOCALVARS . T)))
	(* * Misc edit macros)
	(USERMACROS EVAL Q GETD GETVAL MAKEFN D NEGATE GO SWAP MAKE SWAPC SPLITC JOINC)
	(FNS MAKEFN EDITGETD NEGATE NEGL NEGLST NEGC MKPROGN MKPROGN1 MAKECOM SWAPPEDCOND)
	(BLOCKS (NEGATE NEGATE NEGL NEGLST NEGC (NOLINKFNS . T)
			(GLOBALVARS NEGATIONS))
		(MKPROGN MKPROGN MKPROGN1 (NOLINKFNS . T))
		(NIL MAKEFN EDITGETD (GLOBALVARS CLISPARRAY MACROPROPS)
		     MAKECOM SWAPPEDCOND (LOCALVARS . T)))
	(* * Time stamp on functions when edited)
	(DECLARE: DONTCOPY (P (* User enables this by an (ADDTOVAR INITIALSLIST (USERNAME . initials:)
								   )
				 in his INIT.LISP. E.g. (ADDTOVAR INITIALSLIST (MASINTER . lmm:))
				 - The date fixup is enabled by the variable INITIALS. The function 
				 SETINITIALS sets INITIALS from INITIALSLIST and USERNAME at load 
				 time, and after a sysin.)))
	(FNS FIXEDITDATE EDITDATE? EDITDATE SETINITIALS)
	(INITVARS (INITIALS)
		  (INITIALSLST)
		  (DEFAULTINITIALS (QUOTE edited:)))
	(GLOBALVARS LAMBDASPLST NORMALCOMMENTSFLG COMMENTFLG FIRSTNAME INITIALS INITIALSLST 
		    DEFAULTINITIALS FILEPKGFLG DFNFLG)
	(P (MOVD? (QUOTE NILL)
		  (QUOTE PREEDITFN)))
	(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
									      (NLAML MAKECOM 
										     CHARMACRO)
									      (LAMA])

(RPAQQ EDITOPS ((INSERT (BEFORE AFTER FOR)
			(EDIT: #2 #3 #1))
		(REPLACE (WITH BY)
			 (EDIT: : #1 #3))
		(CHANGE (TO)
			(EDIT: : #1 #3))
		(DELETE NIL (EDIT: : #1))
		(EMBED (IN WITH)
		       (EDITMBD #1 #3))
		(SURROUND (WITH IN)
			  (EDITMBD #1 #3))
		(MOVE (TO)
		      (EDITMV #1 (CAR #3)
			      (CDR #3)))
		(EXTRACT (FROM)
			 (EDITXTR #3 #1))
		(SWITCH (AND)
			(EDITSW #1 #3))))

(RPAQQ MAXLOOP 30)

(RPAQQ EDITRACEFN NIL)

(RPAQQ UPFINDFLG T)

(RPAQQ MAXLEVEL 300)

(RPAQQ FINDFLAG NIL)

(RPAQQ EDITQUIETFLG NIL)

(RPAQ? EDITSMASHUSERFN )

(RPAQ? EDITEMBEDTOKEN (QUOTE &))

(RPAQ? EDITUSERFN )

(RPAQ? CHANGESARRAY )

(RPAQ? EDITUNSAVEBLOCKFLG T)

(RPAQ? EDITLOADFNSFLG (QUOTE (T)))

(RPAQ? EDITMACROS )

(RPAQ? USERMACROS )

(ADDTOVAR HISTORYCOMS ?? REDO REPEAT FIX USE ... NAME RETRIEVE DO !N !E !F TYPE-AHEAD  BUFS ;)

(ADDTOVAR DONTSAVEHISTORYCOMS SAVE P ? PP PP* E ;)

(ADDTOVAR EDITCOMSA OK STOP SAVE TTY: E ? PP PP* PPV P ↑ !0 MARK UNDO !UNDO TEST UNBLOCK ← \ \P ←← F 
		       BF UP DELETE NX BK !NX ?? REDO REPEAT FIX USE NAME RETRIEVE DO !N !E !F 
		       TYPE-AHEAD)

(ADDTOVAR EDITCOMSL S R R1 RC RC1 E I N P F FS F= ORF BF NTH IF RI RO LI LO BI BO M NX BK ORR MBD XTR 
		      THRU TO A B : AFTER BEFORE MV LP LPQ LC LCL ← BELOW SW BIND COMS ORIGINAL 
		      INSERT REPLACE CHANGE DELETE EMBED SURROUND MOVE EXTRACT SWITCH ?? REDO REPEAT 
		      FIX USE NAME RETRIEVE DO MARK \)

(ADDTOVAR EDITMACROS [REPACK NIL (IF (LISTP (##))
				     (1)
				     NIL)
			     (I : ([LAMBDA (X Y)
					   (SETQ COM (QUOTE REPACK))
					   [SETQ Y (APPLY (QUOTE CONCAT)
							  (EDITE (UNPACK X]
					   [COND ((NOT (STRINGP X))
						  (SETQ Y (MKATOM Y]
					   (PRINT Y T T]
				 (##]
		     (* X MARK [ORR [(I >* (COND [(RAISEP)
						  (CONS (QUOTE *)
							(CONS (QUOTE %%)
							      (QUOTE X]
						 (T (CONS (QUOTE *)
							  (QUOTE X]
				    ((E (QUOTE CAN'T]
			←←)
		     (CAP NIL RAISE (I 1 (L-CASE (## 1)
						 T)))
		     [LOWER (C)
			    (I R (QUOTE C)
			       (L-CASE (QUOTE C]
		     (RAISE (C)
			    (I R (L-CASE (QUOTE C))
			       (QUOTE C)))
		     [RAISE NIL (IF (NLISTP (##))
				    UP NIL)
			    (I 1 (U-CASE (## 1]
		     [LOWER NIL (IF (NLISTP (##))
				    UP NIL)
			    (I 1 (L-CASE (## 1]
		     [2ND X (ORR ((LC . X)
				  (LC . X]
		     [3RD X (ORR ((LC . X)
				  (LC . X)
				  (LC . X]
		     (%%F (X Y)
			  (E (EDITQF (L-CASE (QUOTE X)
					     (QUOTE Y)))
			     T))
		     [%% X (COMS (CONS (CAR (QUOTE X))
				       (COMMENT3 (CDR (QUOTE X))
						 (CAR (LAST L]
		     (NEX NIL (BELOW ←)
			  NX)
		     (NEX (X)
			  (BELOW X)
			  NX)
		     [REPACK NIL (IF (LISTP (##))
				     (1)
				     NIL)
			     (I : ([LAMBDA (X Y)
					   (SETQ COM (QUOTE REPACK))
					   [SETQ Y (APPLY (QUOTE CONCAT)
							  (EDITE (UNPACK X]
					   [COND ((NOT (STRINGP X))
						  (SETQ Y (MKATOM Y]
					   (PRINT Y T T]
				 (##]
		     (REPACK (X)
			     (LC . X)
			     REPACK)
		     (>* (X)
			 (BIND (MARK #1)
			       0
			       (← ((*ANY* PROG PROGN COND SELECTQ LAMBDA NLAMBDA ASSEMBLE)
				   --))
			       (MARK #2)
			       (E (SETQ #3 (SELECTQ (## 1)
						    ((COND SELECTQ)
						     2)
						    1))
				  T)
			       (\ #1)
			       (ORR (1 1)
				    (1)
				    NIL)
			       (BELOW (\ #2)
				      #3)
			       (IF (QUOTE X)
				   [(ORR (NX (B X))
					 ((IF (EQ (## (\ #2)
						      0 1)
						  (QUOTE PROG))
					      NIL
					      (BK))
					  (A X))
					 ((\ #2)
					  (>* X]
				   NIL)))
		     (SHOW X (F (*ANY* . X)
				T)
			   (LPQ MARK (ORR (1 !0)
					  NIL)
				P ←← (F (*ANY* . X)
					N))
			   (E (QUOTE done)))
		     (EXAM X (F (*ANY* . X)
				T)
			   (BIND (LPQ (MARK #1)
				      (ORR (1 !0 P)
					   NIL)
				      (MARK #2)
				      TTY:
				      (MARK #3)
				      (IF (EQ (## (\ #3))
					      (## (\ #2)))
					  ((\ #1))
					  NIL)
				      (F (*ANY* . X)
					 N)))
			   (E (QUOTE done)))
		     (PP* NIL (RESETVAR **COMMENT**FLG NIL PP)))

(ADDTOVAR EDITCOMSA CAP LOWER RAISE NEX REPACK PP*)

(ADDTOVAR EDITCOMSL LOWER RAISE 2ND 3RD %%F %% REPACK * >* EXAM SHOW)

(ADDTOVAR DONTSAVEHISTORYCOMS PP*)
(* * control chars for moving around in the editor)

(DEFINEQ

(SETTERMCHARS
  (LAMBDA (NEXTCHAR BKCHAR LASTCHAR UNQUOTECHAR 2CHAR PPCHAR)
                                                            (* lmm "11-SEP-78 04:57")
    (COND
      ((SETQ NEXTCHAR (INTCHECK NEXTCHAR))                  (* NEXTCHAR (usu. control-J) goes to the next entry)
	(/SETSYNTAX NEXTCHAR (QUOTE (MACRO FIRST IMMEDIATE (LAMBDA NIL
					     (CHARMACRO NXP))))
		    EDITRDTBL)))
    (COND
      ((SETQ LASTCHAR (INTCHECK LASTCHAR))                  (* LASTCHAR (usu. control-Z) to the editor will go to 
							    the last thing and print it)
	(/SETSYNTAX LASTCHAR (QUOTE (MACRO FIRST IMMEDIATE (LAMBDA NIL
					     (CHARMACRO -1P))))
		    EDITRDTBL)
	(/ECHOCONTROL LASTCHAR (QUOTE IGNORE))))
    (COND
      ((SETQ 2CHAR (INTCHECK 2CHAR))                        (* 2CHAR (usu. Control N) to the editor will go to 2 
							    (or 1) and print it)
	(/SETSYNTAX 2CHAR (QUOTE (MACRO FIRST IMMEDIATE (LAMBDA NIL
					  (CHARMACRO 2P))))
		    EDITRDTBL)
	(/ECHOCONTROL 2CHAR (QUOTE IGNORE))))
    (COND
      ((SETQ BKCHAR (INTCHECK BKCHAR))                      (* BKCHAR (usu. control H) to the editor will go back 
							    (or up) and then print)
	(/SETSYNTAX BKCHAR (QUOTE (MACRO FIRST IMMEDIATE ESCQUOTE (LAMBDA NIL
					   (CHARMACRO BKP))))
		    EDITRDTBL)
	(/ECHOCONTROL BKCHAR (QUOTE IGNORE))))
    (COND
      ((SETQ UNQUOTECHAR (INTCHECK UNQUOTECHAR))            (* UNQUOTECHAR (usu. control Y 
							    (Yank)) is an 'unquote' -- reads next thing and evals 
							    it)
	(/SETSYNTAX UNQUOTECHAR (QUOTE (MACRO FIRST (LAMBDA (FILE RDTBL)
						(EVAL (READ FILE RDTBL)))))
		    T)
	(/SETSYNTAX UNQUOTECHAR T EDITRDTBL)))
    (COND
      ((SETQ PPCHAR (INTCHECK PPCHAR))                      (* PPCHAR (usu. control-O) to the editor will print 
							    current expression)
	(/SETSYNTAX PPCHAR (QUOTE (SPLICE FIRST IMMEDIATE ESCQUOTE (LAMBDA NIL
					    (TERPRI T)
					    (## PP*)
					    (PRIN1 (QUOTE *)
						   T)
					    NIL)))
		    EDITRDTBL)
	(/ECHOCONTROL PPCHAR (QUOTE IGNORE))))))

(INTCHECK
  [LAMBDA (CHAR)                                            (* lmm "29-NOV-77 20:32")
    (PROG ((CHR CHAR)
	   NCHR)
          [COND
	    ((LISTP CHR)
	      (SETQ CHR (CAR CHR]
          (COND
	    ((NULL CHR)
	      (RETURN)))
          [COND
	    ((NOT (FIXP CHR))
	      (SETQ CHR (CHCON1 CHR]
          [COND
	    ((IGREATERP CHR 64)
	      (SETQ CHR (IDIFFERENCE CHR 64]
          (COND
	    ((NOT (GETINTERRUPT CHR))
	      (RETURN CHR)))
          (COND
	    ((NLISTP CHAR)
	      (PRIN1 "control-" T)
	      (PRIN1 (FCHARACTER (IPLUS CHR 64))
		     T)
	      (PRIN1 " is an interrupt and can't be an edit control-character" T)
	      (TERPRI T))
	    (T (COND
		 [(SETQ NCHR (CADR CHAR))
		   (OR (FIXP NCHR)
		       (SETQ NCHR (CHCON1 NCHR)))
		   [COND
		     ((IGREATERP NCHR 64)
		       (SETQ NCHR (IDIFFERENCE NCHR 64]
		   (INTCHAR (CONS NCHR (CDR (OR (INTCHAR CHR)
						(HELP]
		 (T (INTCHAR CHR)))
	       (RETURN CHR])

(CHARMACRO
  [NLAMBDA (X)                                              (* NOBIND "18-JUL-78 22:15")
    (CFOBF)                                                 (* clear file output buffer;
					no-op on dorado)
    (TERPRI T)
												     |
    X])
)

(RPAQ? EDITCHARACTERS )

(RPAQQ NEGATIONS ((NEQ . EQ)
		  (NLISTP . LISTP)
		  (GO . GO)
		  (ERROR . ERROR)
		  (ERRORX . ERRORX)
		  (RETURN . RETURN)
		  (RETFROM . RETFROM)
		  (RETTO . RETTO)
		  (IGREATERP . ILEQ)
		  (ILESSP . IGEQ)))

(ADDTOVAR EDITMACROS (NXP NIL [ORR (NX)
				   (!NX (E (PRIN1 "> " T)
					   T))
				   ((E (PROGN (SETQQ COM NX)
					      (ERROR!]
			  P)
		     [-1P NIL (ORR (-1 P)
				   ((E (PROGN (SETQQ COM -1)
					      (ERROR!]
		     (BKP NIL [ORR (BK)
				   (!0)
				   ((E (PROGN (SETQQ COM BK)
					      (ERROR!]
			  P)
		     (2P NIL [ORR (2)
				  (1)
				  ((E (PROGN (SETQQ COM 2)
					     (ERROR!]
			 P))

(ADDTOVAR EDITCOMSA NXP -1P BKP 2P)

(ADDTOVAR COMPACTHISTORYCOMS 2P NXP BKP -1P)

(ADDTOVAR COMPACTHISTORYCOMS 2P NXP BKP -1P)
(DECLARE: DONTCOPY 
(DECLARE: EVAL@COMPILE 

(PUTPROPS CFOBF MACRO (NIL (ASSEMBLE NIL
				     (MOVEI 1 , 101Q)
				     (JSYS 101Q))))

(PUTPROPS CFOBF DMACRO (NIL NIL))
)
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: SETTERMCHARS SETTERMCHARS INTCHECK (NOLINKFNS . T)
	(GLOBALVARS EDITRDTBL))
(BLOCK: NIL CHARMACRO (LOCALVARS . T))
]
(* * macros for calling editor)


(ADDTOVAR EDITMACROS [EV NIL (ORR [(E (LISPXEVAL (LIST (QUOTE EDITV)
						       (FIRSTATOM (##)))
						 (QUOTE EV->]
				  ((E (QUOTE EV?]
		     [EP NIL (ORR [(E (LISPXEVAL (LIST (QUOTE EDITP)
						       (FIRSTATOM (##)))
						 (QUOTE EP->]
				  ((E (QUOTE EP?]
		     [EF NIL (ORR [(E (LISPXEVAL (LIST (QUOTE EDITF)
						       (FIRSTATOM (##)))
						 (QUOTE EF->]
				  ((E (QUOTE EF?])

(ADDTOVAR EDITCOMSA EV EP EF)

(ADDTOVAR DONTSAVEHISTORYCOMS EF EV EP)

(ADDTOVAR DONTSAVEHISTORYCOMS EF EV EP)
(DEFINEQ

(FIRSTATOM
  [LAMBDA (X)                                               (* NOBIND "18-JUL-78 21:57")
                                                            (* Used by EF macro)
    (COND
      ((NLISTP X)
	X)
      (T (FIRSTATOM (CAR X])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL FIRSTATOM (LOCALVARS . T))
]
(* * Misc edit macros)


(ADDTOVAR EDITMACROS [EVAL NIL (ORR [(E (LISPXEVAL (## (ORR (UP 1)
							    NIL))
						   (QUOTE *]
				    ((E (QUOTE EVAL?]
		     [GO (LAB)
			 (ORR ((← ((*ANY* PROG ASSEMBLE DPROG)
				   -- LAB --))
			       F LAB (ORR 2 1)
			       P)
			      ((E (PROGN (SETQQ COM LAB)
					 (ERROR!]
		     (JOINC NIL (F COND T)
			    UP
			    (BI 1 2)
			    1
			    (BO 2)
			    (2)
			    (RO 1)
			    (BO 1))
		     (NEGATE NIL UP (I 1 (NEGATE (## 1)))
			     1)
		     (SPLITC (X)
			     (F COND T)
			     (BI 1 X)
			     (IF [AND (EQ (## 2 1)
					  T)
				      (## 2 2)
				      (NULL (CDDR (##]
				 ((BO 2)
				  (2))
				 ((-2 COND)
				  (LI 2)))
			     UP
			     (BO 1))
		     (SWAPC NIL (F (COND --)
				   T)
			    UP
			    (I 1 (SWAPPEDCOND (## 1)))
			    1)
		     (MAKE (VAR . VALS)
			   (COMS (MAKECOM VAR VALS)))
		     (D NIL (:)
			1 P)
		     (Q NIL (MBD QUOTE))
		     (MAKEFN (FORM ARGS N M)
			     [IF (QUOTE M)
				 ((BI N M)
				  (LC . N)
				  (BELOW \))
				 ((IF (QUOTE N)
				      ((BI N -1)
				       (LC . N)
				       (BELOW \))
				      ((LI 1]
			     (E (MAKEFN (QUOTE FORM)
					(QUOTE ARGS)
					(##))
				T)
			     UP
			     (1 FORM)
			     1)
		     (SWAP (LC1 LC2)
			   (BIND (MARK #3)
				 (LC . LC1)
				 (MARK #1)
				 (\ #3)
				 (LC . LC2)
				 (MARK #2)
				 [IF (NOT (OR (FMEMB (CAR #1)
						     #2)
					      (FMEMB (CAR #2)
						     #1)))
				     (UP (\ #1)
					 UP
					 (I 1 (CAR #2))
					 (\ #2)
					 UP
					 (I 1 (CAR #1)))
				     ((E (QUOTE (NESTED EXPRESSIONS]
				 (\ #3)))
		     (GETD NIL UP [ORR [(I 1 (OR [EDITGETD (## 1)
							   (AND (CDR L)
								(EDITL0 L (QUOTE (!0]
						 (ERROR!]
				       ((E (QUOTE GETD?]
			   1)
		     (GETVAL NIL UP [ORR [(I 1 (EVAL (## 1)
						     (QUOTE *]
					 ((E (QUOTE GETVAL?]
			     1))

(ADDTOVAR EDITCOMSA JOINC EVAL NEGATE SWAPC D Q GETD GETVAL)

(ADDTOVAR EDITCOMSL SPLITC MAKE MAKEFN SWAP GO)
(DEFINEQ

(MAKEFN
  [LAMBDA (FORM ARGLIST BODY)                               (* wt: " 2-MAR-79 20:47")
                                                            (* called from MAKEFN edit 
					macro)
    (COND
      ((AND (LITATOM FORM)
	    (FNTYP (CAR BODY))
	    (NULL (CDR BODY))
	    (NULL ARGLIST))
	(DEFINE (LIST (CONS FORM BODY)))
	(FIXEDITDATE (GETD FORM)))
      (T (PROG ((A ARGLIST)
												     |
		(ACTUAL (CDR FORM))
												     |
		DEF)
												     |
	       (OR (AND (LISTP FORM)
												     |
			(CAR FORM)
												     |
			(LITATOM (CAR FORM)))
												     |
		   (ERROR FORM "? " T))
												     |
	   LP  (COND
												     |
		 ((LISTP ACTUAL)
												     |
		   [COND
												     |
		     ((NLISTP A)
												     |
		       (SETQ ARGLIST
												     |
			 (NCONC ARGLIST
												     |
				(SETQ A
												     |
				  (LIST (COND
												     |
					  ((LITATOM (CAR ACTUAL))
												     |
					    (CAR ACTUAL))
												     |
					  (T (OR [CAR (SOME (QUOTE (X Y Z A B C D))
												     |
							    (FUNCTION (LAMBDA (X)
												     |
								(NOT (FMEMB X ARGLIST]
												     |
						 (GENSYM]
												     |
		   (AND (NEQ (CAR A)
												     |
			     (CAR ACTUAL))
												     |
			(ERSETQ (ESUBST (CAR A)
												     |
					(CAR ACTUAL)
												     |
					BODY)))
												     |
		   (SETQ A (CDR A))
												     |
		   (SETQ ACTUAL (CDR ACTUAL))
												     |
		   (GO LP)))
												     |
	       [DEFINE (LIST (LIST (CAR FORM)
												     |
				   (SETQ DEF (CONS (QUOTE LAMBDA)
												     |
						   (CONS ARGLIST BODY]
												     |
	       (FIXEDITDATE DEF])

(EDITGETD
  [LAMBDA (X EDITCHAIN)            (* wt: "10-OCT-78 11:57")
                                   (* used by the GETD edit macro)
    (AND (LISTP X)
	 (PROG (DEF TAIL (FN (CAR X)))
	       (RETURN (COND
			 ((LISTP FN)
			   (SELECTQ (CAR FN)
				    [LAMBDA (MKPROGN (SUBPAIR (CADR FN)
							      (CDR X)
							      (CDDR FN]
				    (OPENLAMBDA (EXPANDOPENLAMBDA FN (CDR X)))
				    NIL))
			 ((AND (GETLIS FN COMPILERMACROPROPS)
			       (NOT (EQUAL (SETQ DEF (EXPANDMACRO X T))
					   X)))
			   (COPY DEF))
			 [(GETPROP FN (QUOTE CLISPWORD))
			   [DWIMIFY X T (OR EDITCHAIN (QUOTE (NIL]
			   (COND
			     ((NEQ FN (CAR X))
                                   (* form changed)
			       X)
			     ((SETQ DEF (GETHASH X CLISPARRAY))
			       (COPY DEF]
			 ((SETQ DEF (GETDEF FN))
			   [SETQ TAIL (SUBSET (CDDR DEF)
					      (FUNCTION (LAMBDA (X)
						  (NEQ (CAR X)
						       (QUOTE *]
			   (COND
			     ((NULL (CADR DEF))
                                   (* no args)
			       (COPY (MKPROGN TAIL)))
			     ((OR (EQ (CAR DEF)
				      (QUOTE NLAMBDA))
				  (NLISTP (CADR DEF)))
                                   (* NLAMBDA)
                                   (* just open code it)
			       (CONS (CONS (CAR DEF)
					   (CONS (CADR DEF)
						 TAIL))
				     (CDR DEF)))
			     (T (MKPROGN (SUBPAIR (CADR DEF)
						  (CDR X)
						  TAIL T])

(NEGATE
  [LAMBDA (X)                      (* lmm " 6-DEC-80 16:00")
    (SELECTQ (CAR (LISTP X))
	     ((NOT NULL)
	       (CADR X))
	     [AND (CONS (QUOTE OR)
			(NEGLST (CDR X]
	     [OR (CONS (QUOTE AND)
		       (NEGLST (CDR X]
	     (ZEROP (LIST (QUOTE NEQ)
			  (CADR X)
			  0))
	     [COND (COND [[AND (NULL (CDDR X))
			       (NULL (CDR (CDADR X]
			   (NEGATE (CONS (QUOTE AND)
					 (CADR X]
			 (T (CONS (QUOTE COND)
				  (NEGC (CDR X]
	     [SELECTQ (CONS (QUOTE SELECTQ)
			    (CONS (CADR X)
				  (MAPLIST (CDDR X)
					   (FUNCTION (LAMBDA (X)
					       (COND
						 [(CDR X)
						   (CONS (CAAR X)
							 (NEGL (CDAR X]
						 (T (NEGATE (CAR X]
	     [PROGN (MKPROGN (NEGL (CDR X]
	     [PROG1 (CONS (QUOTE PROG1)
			  (CONS (NEGATE (CADR X))
				(CDDR X]
	     (QUOTE (NULL (CADR X)))
	     [(CONS)               (* functions which always return non-NIL)
	       (MKPROGN (APPEND (CDR X)
				(LIST NIL]
	     (COND
	       [(for Y in NEGATIONS do (COND
					 [(EQ (CAR Y)
					      (CAR X))
					   (RETURN (CONS (CDR Y)
							 (CDR X]
					 ((EQ (CDR Y)
					      (CAR X))
					   (RETURN (CONS (CAR Y)
							 (CDR X]
	       (T (OR (NULL X)
		      (AND (NEQ X T)
			   (NOT (OR (NUMBERP X)
				    (STRINGP X)))
			   (LIST (QUOTE NOT)
				 X])

(NEGL
  [LAMBDA (L)                                               (* lmm: " 7-FEB-77 17:17:51")
    (COND
      [(NULL (CDR L))
	(LIST (NEGATE (CAR L]
      (T (CONS (CAR L)
	       (NEGL (CDR L])

(NEGLST
  [LAMBDA (L)
    (MAPCAR L (FUNCTION NEGATE])

(NEGC
  (LAMBDA (X)                                               (* lmm "14-SEP-78 23:07")
    (COND
      ((NULL X)
	(LIST (LIST T T)))
      ((NULL (CDAR X))                                      (* (COND (A) . TAIL) -> (NOT 
							    (OR A (COND . TAIL))) -> (AND 
							    (NOT A) (NOT (COND . TAIL))))
	(LIST (LIST (NEGATE (CAAR X))
		    (OR (NULL (CDR X))
			(AND (SETQ X (NEGC (CDR X)))
			     (CONS (QUOTE COND)
				   X))))))
      (T (CONS (CONS (CAAR X)
		     (NEGL (CDAR X)))
	       (AND (NEQ (CAAR X)
			 T)
		    (NEGC (CDR X))))))))

(MKPROGN
  [LAMBDA (L)                                               (* wt: "18-JUL-78 12:57")
    (COND
      ((CDR (SETQ L (MKPROGN1 L)))
	(CONS (QUOTE PROGN)
	      L))
      (T (CAR L])

(MKPROGN1
  [LAMBDA (L)                                               (* lmm "21-SEP-77 15:19")
    (COND
      ((NULL (CDR L))
	(COND
	  ((EQ (CAAR L)
	       (QUOTE PROGN))
	    (CDAR L))
	  (T L)))
      ((NLISTP (CAR L))
	(MKPROGN1 (CDR L)))
      (T (SELECTQ (CAAR L)
		  [(PROGN LIST CONS CAR CDR NOT NULL)
		    (MKPROGN1 (APPEND (CDAR L)
				      (CDR L]
		  (QUOTE (MKPROGN1 (CDR L)))
		  (CONS (CAR L)
			(MKPROGN1 (CDR L])

(MAKECOM
  [NLAMBDA (VAR VALS)                                       (* wt: "19-JUL-78 11:35")
    (PROG (ARGNAMES (FORM (##)))
												     |
          (SETQ ARGNAMES (SMARTARGLIST (SETQ COM (CAR FORM))
				       NIL FORM))
          (OR [AND (LISTP ARGNAMES)
		   (OR (FMEMB (SETQ COM VAR)
			      ARGNAMES)
		       (SETQ VAR (FIXSPELL VAR NIL (APPEND ARGNAMES)
					   NIL]
	      (ERROR!))
          (RETURN (PROG (($$LST2 ARGNAMES)
												     |
			 $$VAL I ARG LST)                   (* (FOR I FROM 2 AS ARG IN VALS UNTIL ARG=VAR DO --))
												     |
		        (SETQ I 2)
		    $$LP[SETQ ARG (CAR (OR (LISTP $$LST2)
					   (GO $$OUT]
		        [COND
			  ((EQ ARG VAR)
			    (RETURN (COND
				      ((NOT (OR VALS (NULL (CDR FORM))
						(CDDR FORM)))
					(LIST I))
				      [(CDR FORM)
					(LIST I (COND
						((CDR VALS)
						  VALS)
						(T (CAR VALS]
				      (T (CONS (QUOTE N)
					       (NCONC1 LST (COND
												     |
							 ((CDR VALS)
												     |
							   VALS)
												     |
							 (T (CAR VALS]
												     |
		        [COND
			  ((NULL (SETQ FORM (CDR FORM)))
			    (SETQ LST (CONS NIL LST]
		    $$ITERATE
		        (SETQ I (IPLUS I 1))
		        (SETQ $$LST2 (CDR $$LST2))
		        (GO $$LP)
		    $$OUT
		        (ERROR!)
		        (RETURN $$VAL])

(SWAPPEDCOND
  [LAMBDA (CND)                                             (* lmm "19-JUL-78 17:57")
    (PROG ((C1 (CADR CND))
	   (CTAIL (CDDR CND))
	   (C2 (CADDR CND)))
          (COND
	    ((NULL (CDR C1))                                (* cannot negate (COND (A) --))
	      (ERROR!)))
          (RETURN (CONS (QUOTE COND)
			(CONS [CONS (NEGATE (CAR C1))
				    (OR (AND (EQ (CAR C2)
						 T)
					     (CDR C2))
					(COND
					  ((NULL CTAIL)     (* only one clause. Turn (COND 
							    (A --)) into (COND ((NOT A) NIL) 
							    (T --)))
					    (LIST NIL))
					  (T                (* embed multiple subsequent clauses into one COND)
					     (LIST (CONS (QUOTE COND)
							 CTAIL]
			      (COND
				((AND (NULL (CDDR C1))
				      (EQ (CAADR C1)
					  (QUOTE COND)))    (* consequent of first clause is a COND itself.
							    Expand out in the tail)
				  (CDADR C1))
				((AND (NULL (CADR C1))
				      (NULL (CDDR C1)))     (* (COND (A NIL) --) when swapped doesn't need a final T
							    clause)
				  NIL)
				(T (LIST (CONS T (CDR C1])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NEGATE NEGATE NEGL NEGLST NEGC (NOLINKFNS . T)
	(GLOBALVARS NEGATIONS))
(BLOCK: MKPROGN MKPROGN MKPROGN1 (NOLINKFNS . T))
(BLOCK: NIL MAKEFN EDITGETD (GLOBALVARS CLISPARRAY MACROPROPS)
	MAKECOM SWAPPEDCOND (LOCALVARS . T))
]
(* * Time stamp on functions when edited)

(DECLARE: DONTCOPY 
(* User enables this by an (ADDTOVAR INITIALSLIST (USERNAME . initials:))
   in his INIT.LISP. E.g. (ADDTOVAR INITIALSLIST (MASINTER . lmm:))
   - The date fixup is enabled by the variable INITIALS. The function SETINITIALS sets INITIALS from 
   INITIALSLIST and USERNAME at load time, and after a sysin.)
)
(DEFINEQ

(FIXEDITDATE
  [LAMBDA (EXPR)                   (* NOBIND "18-JUL-78 21:11")
                                   (* Inserts or replaces previous edit date)
    (AND INITIALS (LISTP EXPR)
	 (FMEMB (CAR EXPR)
		LAMBDASPLST)
	 (LISTP (CDR EXPR))
	 (PROG ((E (CDDR EXPR)))
	   RETRY
	       [COND
		 ((NLISTP E)
		   (RETURN))
		 ((LISTP (CAR E))
		   (SELECTQ (CAAR E)
			    ((CLISP: DECLARE)
			      (SETQ E (CDR E))
			      (GO RETRY))
			    [BREAK1 (COND
				      ((EQ (CAR (CADAR E))
					   (QUOTE PROGN))
					(SETQ E (CDR (CADAR E)))
					(GO RETRY]
			    (ADV-PROG 
                                   (* No easy way to mark cleanly the date of an advised function)
				      (RETURN))
			    (COND
			      ((AND (EQ (CAAR E)
					COMMENTFLG)
				    (EQ (CADAR E)
					(QUOTE DECLARATIONS:)))
				(SETQ E (CDR E))
				(GO RETRY]
	       (COND
		 ((AND (LISTP (CDR E))
		       (EDITDATE? (CAR E)))
		   (/RPLACA E (EDITDATE (CAR E)
					INITIALS)))
		 (T (/ATTACH (EDITDATE NIL INITIALS)
			     E)))
	       (RETURN EXPR])

(EDITDATE?
  [LAMBDA (COMMENT)                                         (* rmk: " 6-JUN-82 15:25")

          (* Tests to see if a given common is in fact an edit date -- this has to be general enough to recognize the most 
	  comment comment forms while specific enough to not recognize things that are not edit dates)


    (DECLARE (LOCALVARS . T))
    (COND
      [(LISTP COMMENT)
	(COND
	  ((EQ (CAR COMMENT)
	       COMMENTFLG)
	    [COND
	      ((NULL NORMALCOMMENTSFLG)
		(SETQ COMMENT (GETCOMMENT COMMENT]
	    (OR (EQ (CADR COMMENT)
		    INITIALS)
		(AND (LITATOM (CAR (CDR COMMENT)))
		     (OR [AND (NULL (CDDR (CDDDDR COMMENT)))
			      (OR (STRINGP (CADDR COMMENT))
				  (EQ (NTHCHARCODE (CADR COMMENT)
						   -1)
				      (CHARCODE :]
			 (AND (AND (EQ (CAR (CDR COMMENT))
				       (QUOTE Edited))
				   (EQ (CAR (CDR (CDR COMMENT)))
				       (QUOTE by)))
			      (NULL (CDR (CDDDDR (CDDDDR COMMENT]
      ((STRINGP COMMENT])

(EDITDATE
  [LAMBDA (OLDATE INITLS)          (* lmm " 7-OCT-81 10:31")
                                   (* Generates a new date from an old one)
    (PROG (STR)
          (SETQ STR (SUBSTRING (SETQ STR (DATE))
			       1 15 STR))
          (RETURN (COND
		    ([OR (NLISTP OLDATE)
			 (NEQ (CAR OLDATE)
			      COMMENTFLG)
			 (NOT (STRINGP (CADDR OLDATE]
		      (LIST COMMENTFLG INITLS STR))
		    (T (RPLACA (CDR (RPLACA (CDR OLDATE)
					    INITLS))
			       STR)
		       OLDATE])

(SETINITIALS
  [LAMBDA NIL                      (* FOO "27-SEP-79 16:37")
                                   (* (TEITELMAN . wt:) "20-SEP-79 13:50")
    (RESETVARS (FILEPKGFLG (DFNFLG T))
	       (RETURN (PROG (TEM)
			     (RETURN (COND
				       [(SETQ TEM (FASSOC (MKATOM (USERNAME))
							  INITIALSLST))
					 (COND
					   ((NLISTP (CDR TEM))
					     (SAVESET (QUOTE INITIALS)
						      (CDR TEM)))
					   (T (SAVESET (QUOTE FIRSTNAME)
						       (CADR TEM))
					      (SAVESET (QUOTE INITIALS)
						       (CADDR TEM]
				       (T (SAVESET (QUOTE INITIALS)
						   DEFAULTINITIALS])
)

(RPAQ? INITIALS )

(RPAQ? INITIALSLST )

(RPAQ? DEFAULTINITIALS (QUOTE edited:))
(DECLARE: DOEVAL@COMPILE DONTCOPY

(ADDTOVAR GLOBALVARS LAMBDASPLST NORMALCOMMENTSFLG COMMENTFLG FIRSTNAME INITIALS INITIALSLST 
	  DEFAULTINITIALS FILEPKGFLG DFNFLG)
)
(MOVD? (QUOTE NILL)
       (QUOTE PREEDITFN))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML MAKECOM CHARMACRO)

(ADDTOVAR LAMA )
)
(PUTPROPS WEDIT COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (7682 11150 (SETTERMCHARS 7694 . 9874) (INTCHECK 9878 . 10871) (CHARMACRO 10875 . 11147)
) (12966 13242 (FIRSTATOM 12978 . 13239)) (15419 24273 (MAKEFN 15431 . 17275) (EDITGETD 17279 . 18749)
 (NEGATE 18753 . 20148) (NEGL 20152 . 20368) (NEGLST 20372 . 20430) (NEGC 20434 . 21040) (MKPROGN 
21044 . 21249) (MKPROGN1 21253 . 21730) (MAKECOM 21734 . 23119) (SWAPPEDCOND 23123 . 24270)) (24948 
28225 (FIXEDITDATE 24960 . 26061) (EDITDATE? 26065 . 27065) (EDITDATE 27069 . 27587) (SETINITIALS 
27591 . 28222)))))
STOP