(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