(FILECREATED "17-Jun-86 15:13:11" {ERIS}<LISPCORE>SOURCES>WEDIT.;21 47100
changes to: (FNS EDITDATE EDITDATE? SETINITIALS)
(VARS WEDITCOMS)
previous date: "10-Jun-86 18:54:03" {ERIS}<LISPCORE>SOURCES>WEDIT.;17)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 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*)
[COMS (* * "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]
[COMS (* * "macros for calling editor")
(USERMACROS EF EV EP)
(ADDVARS (DONTSAVEHISTORYCOMS EF EV EP))
(FNS FIRSTATOM)
(BLOCKS (NIL FIRSTATOM (LOCALVARS . T]
[COMS (* * "Misc edit macros")
(USERMACROS EVAL Q GETD GETVAL MAKEFN D NEGATE GO SWAP MAKE SWAPC IFY SPLITC JOINC)
(FNS MAKEFN EDITGETD EDITGETD-LAMBDA EDITGETD-LET NEGATE NEGL NEGLST NEGC MKPROGN
MKPROGN1 MAKECOM SWAPPEDCOND COND.TO.IF)
(PROP EDITGETD LET CL:IF)
(BLOCKS (NEGATE NEGATE NEGL NEGLST NEGC (NOLINKFNS . T)
(GLOBALVARS NEGATIONS))
(MKPROGN MKPROGN MKPROGN1 (NOLINKFNS . T]
(GLOBALVARS CLISPARRAY MACROPROPS)
(LOCALVARS . T)
(COMS (* * "Time stamp on functions when edited")
(* * "User enables this by an (ADDTOVAR INITIALSLIST (USERNAME )) in his INIT.LISP. E.g. (ADDTOVAR INITIALSLIST (MASINTER ))
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 T)))
(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)))
[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 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) (* lmm " 5-Jun-86 04:39")
(* used by the GETD edit macro)
(AND (LISTP X)
(PROG (DEF (FN (CAR X)))
(RETURN (COND
((LISTP FN)
(EDITGETD-LAMBDA (CADR FN)
(CDDR FN)
(CDR X)))
[(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]
((MACRO-FUNCTION FN)
(COPY (MACROEXPAND-1 X)))
((SETQ DEF (GET FN (QUOTE EDITGETD)))
(FUNCALL DEF X))
((AND (SETQ DEF (GETDEF FN (QUOTE FUNCTIONS)
NIL
(QUOTE NOERROR)))
(EQ (CAR DEF)
(QUOTE DEFUN)))
(EDITGETD-LAMBDA (CADDR DEF)
(CDDDR DEF)
(CDR X)))
((SETQ DEF (GETDEF FN))
(COND
[(EQ (CAR DEF)
(QUOTE NLAMBDA))
(EDITGETD-LAMBDA (CADR DEF)
(CDDR DEF)
(KWOTE (CDR X]
((AND (EQ (CAR DEF)
(QUOTE LAMBDA))
(CADR DEF)
(NLISTP (CADR DEF))) (* LAMBDA spread)
(CONS DEF (CDR X)))
(T (EDITGETD-LAMBDA (CADR DEF)
(CDDR DEF)
(CDR X])
(EDITGETD-LAMBDA
[LAMBDA (ARGS BODY VALS DONE) (* lmm " 5-Jun-86 01:41")
(if (NULL ARGS)
then (if DONE
then (BQUOTE (LET (\, (REVERSE DONE))
(\,@ BODY)))
else (MKPROGN BODY))
elseif (CONSP (CAR ARGS))
then (EDITGETD-LAMBDA (CDR ARGS)
BODY
(CDR VALS)
(CONS (LIST (CAAR ARGS)
(if VALS
then (CAR VALS)
else (CADAR ARGS)))
DONE))
else (SELECTQ (CAR ARGS)
((&ALLOW-OTHER-KEYS &OPTIONAL)
(EDITGETD-LAMBDA (CDR ARGS)
BODY VALS DONE))
(&AUX (EDITGETD-LAMBDA ARGS (APPEND VALS BODY)
NIL DONE))
((&BODY &REST)
[EDITGETD-LAMBDA (CDDR ARGS)
BODY NIL (BQUOTE (((\, (CADR ARGS))
(LIST (\,@ VALS)))
(\,@ DONE])
(EDITGETD-LAMBDA (CDR ARGS)
BODY
(CDR VALS)
(CONS (LIST (CAR ARGS)
(CAR VALS))
DONE])
(EDITGETD-LET
[LAMBDA (FORM) (* lmm " 5-Jun-86 01:44")
(MKPROGN (SUBPAIR (MAPCAR (CADR FORM)
(FUNCTION CAR))
(MAPCAR (CADR FORM)
(FUNCTION CADR))
(CDDR FORM])
(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])
(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])
)
(PUTPROPS LET EDITGETD EDITGETD-LET)
(PUTPROPS CL:IF EDITGETD [LAMBDA (FORM)
(DESTRUCTURING-BIND
(TEST THEN ELSE)
(CDR FORM)
(BQUOTE (COND ((\, TEST)
(\, THEN))
(\,@ (AND ELSE (BQUOTE ((T (\, ELSE])
[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")
(* *
"User enables this by an (ADDTOVAR INITIALSLIST (USERNAME )) in his INIT.LISP. E.g. (ADDTOVAR INITIALSLIST (MASINTER ))
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) (* bvm: "17-Jun-86 14:09")
(* * "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.
We settle for the conservative form of (* initials date-string), since only truly ancient edit dates look any different from that")
(DECLARE (LOCALVARS . T))
(AND (LISTP COMMENT)
(EQMEMB (CAR COMMENT)
COMMENTFLG)
(LISTP (CDR COMMENT))
(LISTP (CDDR COMMENT))
(NULL (CDDDR COMMENT))
(STRINGP (CADDR COMMENT))
(LET ((INITIALS? (CADR COMMENT)))
(AND (NOT (EQMEMB INITIALS? COMMENTFLG))
(OR (EQ INITIALS? INITIALS)
(LITATOM INITIALS?)
(AND (STRINGP INITIALS?)
(ILESSP (NCHARS INITIALS?)
12])
(EDITDATE
[LAMBDA (OLDATE INITLS) (* bvm: "17-Jun-86 14:56")
(* Generates a new date from an old
one)
(LET [(NEWDATE (LIST INITLS (DATE (DATEFORMAT NO.SECONDS]
(COND
((EQMEMB (CAR (LISTP OLDATE))
COMMENTFLG) (* Destructively alter old date.
This is for benefit of DEDIT being
able to find the old form to reprint)
(/RPLACD OLDATE NEWDATE))
(T (CONS (OR (CAR (LISTP COMMENTFLG))
COMMENTFLG)
NEWDATE])
(SETINITIALS
[LAMBDA NIL (* bvm: "13-Jun-86 17:14")
(* * "Sets the default initials to appear in edited code, and sets the user's first name. Called following GREET via POSTGREETFORMS.")
(RESETVARS ((DFNFLG T)
(FILEPKGFLG NIL))
(RETURN (LET ((USER (USERNAME NIL NIL T))
POS TRIPLE)
(SETQ POS (STRPOS "." 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 DEFAULTREGISTRY (STRING-EQUAL (SUBSTRING USER (ADD1 POS)
-1)
DEFAULTREGISTRY))
(* "If there's a registry on the end, and it's the default registry, remove the registry. We assume that DEFAULTREGISTRY has been set by the time that GREET has finished.")
(SETQ USER (SUBSTRING USER 1 (SUB1 POS]
(COND
[(find old TRIPLE in INITIALSLST suchthat (STRING-EQUAL USER
(CAR TRIPLE)))
(*
"OK we found his last name on the INITIALSLST. Now break out his initials and first name")
(COND
((NLISTP (CDR TRIPLE)) (* "old style")
(SAVESET (QUOTE INITIALS)
(CDR TRIPLE)))
(T (SAVESET (QUOTE FIRSTNAME)
(CADR TRIPLE))
(SAVESET (QUOTE INITIALS)
(CADDR TRIPLE]
(T (SAVESET (QUOTE INITIALS)
(COND
((NOT DEFAULTINITIALS)
NIL)
((NEQ DEFAULTINITIALS T)
DEFAULTINITIALS)
(T (MKATOM USER])
)
(RPAQ? INITIALS )
(RPAQ? INITIALSLST )
(RPAQ? DEFAULTINITIALS T)
(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 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (10428 15035 (SETTERMCHARS 10438 . 13440) (INTCHECK 13442 . 14720) (CHARMACRO 14722 .
15033)) (17756 18040 (FIRSTATOM 17766 . 18038)) (22788 39136 (MAKEFN 22798 . 24724) (EDITGETD 24726 .
27022) (EDITGETD-LAMBDA 27024 . 28506) (EDITGETD-LET 28508 . 28828) (NEGATE 28830 . 31159) (NEGL 31161
. 31395) (NEGLST 31397 . 31455) (NEGC 31457 . 32301) (MKPROGN 32303 . 32525) (MKPROGN1 32527 . 33128)
(MAKECOM 33130 . 35368) (SWAPPEDCOND 35370 . 38361) (COND.TO.IF 38363 . 39134)) (40228 46565 (
FIXEDITDATE 40238 . 42105) (EDITDATE? 42107 . 43166) (EDITDATE 43168 . 44027) (SETINITIALS 44029 .
46563)))))
STOP