(FILECREATED "10-Jun-85 22:54:38" {ERIS}<LISPCORE>SOURCES>WEDIT.;9 31628
changes to: (FNS MAKEFN)
previous date: "16-Apr-85 19:46:09" {ERIS}<LISPCORE>SOURCES>WEDIT.;7)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(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 BQUOTE IFY SPLITC JOINC)
(FNS MAKEFN EDITGETD NEGATE NEGL NEGLST NEGC MKPROGN MKPROGN1 MAKECOM SWAPPEDCOND BQUOTIFY
COND.TO.IF)
(BLOCKS (NEGATE NEGATE NEGL NEGLST NEGC (NOLINKFNS . T)
(GLOBALVARS NEGATIONS))
(MKPROGN MKPROGN MKPROGN1 (NOLINKFNS . T)))
(GLOBALVARS CLISPARRAY MACROPROPS)
(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 (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)))
(>* (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)))
(LOWER NIL UP (I 1 (L-CASE (## 1)))
1)
(CAP NIL UP (I 1 (L-CASE (## 1)
T))
1)
[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]
←←)
[LOWER (C)
(I R (QUOTE C)
(L-CASE (QUOTE C]
(RAISE (C)
(I R (L-CASE (QUOTE C))
(QUOTE C)))
(RAISE NIL UP (I 1 (U-CASE (## 1)))
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)
(SHOW X (F (*ANY* . X)
T)
(LPQ MARK (ORR (1 !0)
NIL)
P ←← (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
(PROGN [PUTPROPS CFOBF MACRO (NIL (ASSEMBLE NIL (MOVEI 1 , 65)
(JSYS 65]
(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 USERMACROS (IFY NIL (F (COND --)
T)
UP
[I 1 (COND.TO.IF (CDR (## 1]
1))
(ADDTOVAR EDITMACROS (SWAP (LC1 LC2)
(BIND (MARK #3)
(LC . LC1)
UP
(MARK #1)
(\ #3)
(LC . LC2)
UP
[IF (NOT (OR (FMEMB (CAAR #1)
L)
(FMEMB (CAAR L)
#1)))
((E (SETQ #2 (CAR (##)))
T)
(\ #1)
(E (SETQ #1 (CAR (##)))
T)
(I 1 #2)
\
(I 1 #1))
((E (QUOTE (NESTED EXPRESSIONS]
(\ #3)))
(BQUOTE NIL UP [ORR [(I 1 (OR (CONS (QUOTE BQUOTE)
(OR (BQUOTIFY (## 1))
(ERROR!)))
(ERROR!]
((E (QUOTE BQUOTE?]
1)
[EVAL NIL (ORR [(E (LISPXEVAL (## (ORR (UP 1)
NIL))
(QUOTE *]
((E (QUOTE EVAL?]
[GO (LAB)
(ORR ((← ((*ANY* PROG ASSEMBLE DPROG RESETLST)
-- 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 ((*ANY* COND IF if)
--)
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)
(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 BQUOTE JOINC EVAL NEGATE SWAPC D Q GETD GETVAL)
(ADDTOVAR EDITCOMSL SPLITC MAKE MAKEFN SWAP GO)
(DEFINEQ
(MAKEFN
[LAMBDA (FORM ARGLIST BODY) (* lmm "10-Jun-85 01:37")
(* called from MAKEFN edit macro)
(COND
((AND (LITATOM FORM)
(FNTYP (CAR BODY))
(NULL (CDR BODY))
(NULL ARGLIST))
(DEFINE (LIST (CONS FORM BODY))
T))
(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]
T])
(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) (* JonL "10-Apr-84 22:05")
(SELECTQ (CAR (LISTP X))
((NOT NULL)
(CADR X))
(AND (CONS (QUOTE OR)
(NEGLST (CDR X))))
(OR (CONS (QUOTE AND)
(NEGLST (CDR X))))
(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 "25-SEP-83 23:50")
(SELECTQ (CAR CND)
[(IF if)
(DWIMIFY CND T L)
(COND.TO.IF (CDR (SWAPPEDCOND (COND
((EQ (CAR CND)
(QUOTE COND))
CND)
((GETHASH CND CLISPARRAY))
(T (ERROR!]
[COND (PROG ((C1 (CADR CND))
(CTAIL (CDDR CND))
(C2 (CADDR CND)))
(if (NOT (CDR C1))
then
(* 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]
(SHOULDNT])
(BQUOTIFY
[LAMBDA (FORM) (* lmm "28-Sep-84 11:41")
(* return either list of BQUOTE expression or NIL)
(COND
((LISTP FORM)
(SELECTQ (CAR FORM)
(QUOTE (LIST (CADR FORM)))
[APPEND (LIST (CONS (QUOTE .,)
(CONS (CADR FORM)
(OR [CAR (BQUOTIFY (SETQ FORM (if (CDDDR FORM)
then
(CONS (QUOTE APPEND)
(CDDR FORM))
else (CADDR FORM]
(LIST (QUOTE .,)
FORM]
[LIST (LIST (for X in (CDR FORM) bind BQ join (COND
((BQUOTIFY X))
(T (LIST (QUOTE ,)
X]
[(CONS LIST*)
(LIST (NCONC (OR (BQUOTIFY (CADR FORM))
(LIST (QUOTE ,)
(CADR FORM)))
(PROG [(BQ (BQUOTIFY (SETQ FORM (if (AND (EQ (CAR FORM)
(QUOTE LIST*))
(CDDDR FORM))
then (CONS (QUOTE LIST*)
(CDDR FORM))
else (CADDR FORM]
(RETURN (COND
(BQ (CAR BQ))
(T (LIST (QUOTE .,)
FORM]
NIL))
((OR (NUMBERP FORM)
(STRINGP FORM)
(EQ FORM T)
(NULL FORM))
(LIST FORM])
(COND.TO.IF
[LAMBDA (CONDCLAUSES) (* lmm "25-SEP-83 23:47")
(CONS (QUOTE if)
(CDR (for X in CONDCLAUSES join (COND
((AND (EQ (CAR X)
T)
(NEQ X (CAR CONDCLAUSES)))
(CONS (QUOTE else)
(CDR X)))
(T (CONS (QUOTE elseif)
(CONS (CAR X)
(COND
((CDR X)
(CONS (QUOTE then)
(APPEND (CDR X])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NEGATE NEGATE NEGL NEGLST NEGC (NOLINKFNS . T)
(GLOBALVARS NEGATIONS))
(BLOCK: MKPROGN MKPROGN MKPROGN1 (NOLINKFNS . T))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS CLISPARRAY MACROPROPS)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(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) (* lmm "21-Mar-85 08:45")
(* 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]
(AND (LISTP (CDR COMMENT))
(OR (EQ (CADR COMMENT)
INITIALS)
(AND (LITATOM (CADR 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) (* gbn "16-Apr-85 19:45")
(* Generates a new date from an old one)
(PROG (STR)
(SETQ STR (SUBSTRING (DATE)
1 15))
(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 (* jds "27-Feb-85 15:43")
(* Sets the default initials to appear in edited code,
and sets the user's first name.)
(RESETVARS (FILEPKGFLG (DFNFLG T))
(RETURN (PROG (TEM POS USER)
(SETQ USER (U-CASE (USERNAME)))
(* Get the user's name, making sure it's uppercase)
(SETQ POS (STRPOS (QUOTE %.)
USER)) (* Find out if there's a period in the name, which
would indicate that there's a registry on the end.)
[COND
([AND POS (OR (NULL DEFAULTREGISTRY)
(STREQUAL (SUBSTRING USER (ADD1 POS)
-1)
(MKSTRING DEFAULTREGISTRY]
(* If there's a registry on the end, and it's the
default registry (or there's no default), remove the
registry.)
(SETQ USER (SUBSTRING USER 1 (SUB1 POS]
(RETURN (COND
[(SETQ TEM (FASSOC (MKATOM USER)
INITIALSLST))
(* OK we found his last name on the INITIALSLST.
Now break out his initials and first name)
(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
(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 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (7407 10779 (SETTERMCHARS 7417 . 9550) (INTCHECK 9552 . 10509) (CHARMACRO 10511 . 10777)
) (12504 12771 (FIRSTATOM 12514 . 12769)) (15219 25703 (MAKEFN 15229 . 16579) (EDITGETD 16581 . 18006)
(NEGATE 18008 . 19403) (NEGL 19405 . 19615) (NEGLST 19617 . 19673) (NEGC 19675 . 20264) (MKPROGN
20266 . 20465) (MKPROGN1 20467 . 20927) (MAKECOM 20929 . 22266) (SWAPPEDCOND 22268 . 23771) (BQUOTIFY
23773 . 25260) (COND.TO.IF 25262 . 25701)) (26386 31086 (FIXEDITDATE 26396 . 27458) (EDITDATE? 27460
. 28641) (EDITDATE 28643 . 29255) (SETINITIALS 29257 . 31084)))))
STOP