(FILECREATED "12-AUG-83 10:36:51" {PHYLUM}<LISPCORE>SOURCES>DEDIT.;4 79958
changes to: (FNS DEDITEdit)
previous date: " 7-AUG-83 17:46:45" {PHYLUM}<LISPCORE>SOURCES>DEDIT.;3)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT DEDITCOMS)
(RPAQQ DEDITCOMS [(FNS DF DV DP DC EF EV EP EDITPROP EDITMODE DEDITIT)
(FNS DEDITL DEDITL0 DEDITTTYFN)
(FNS DEDITAfter DEDITBefore DEDITDelete DEDITReplace DEDITSwitch DEDITBI DEDITBO DEDITLI
DEDITLO DEDITRI DEDITRO DEDITUndo UNDOCHOOSE DEDITFind DEDITSwap DEDITCenter DEDITCopy
DEDITReprint DEDITCEdit DEDITEdit DEDITEditCom DEDITARGS DEDITBreak DEDITEval DEDITExit)
(FNS SETPTRTO DEDITCONS DEDITZAPCAR DEDITZAPCDR DEDITZAPNODE DEDITZAPBOTH DEDITFZAP
DEDITZAPCLISP DEDITZAPCHANGES DEDITNCONC DUNDOEDITL DUNDOEDITCOM DUNDOEDITCOM1)
(FNS BSELECT DEDITUSER SELECTKEYS SHADEIFNOTBUF DEDITBUTTONFN DEDITRIGHTBUTTONFN
SELECTELEMENT SELECTREAD SELECTTREE SEARCHMAP WITHINME ONAPARENP SELECTDONE INWINDOW
FINDLCA DOMINATE?)
(FNS POPSELECTION PUSHSELECTION NXTSELECTION TOPSELECTION SWITCHANDSHADE SHADESELECTION
SHADESELECTION1 SHADESELECTION2 PUSHEDITCHAIN MAKESELCHAIN PUSHINTOBUF DUMMYMAPENTRY
FLIPSELS FLIPSELSIN FIXUPSEL NEWSELFOR)
(FNS ACTIVEEDITW FINDEDITW GETEDITW MAKEEDITW NAMEOFEDITW PURGEW MAKECPOSBE SAMEEDITW
TOPEDITW UNDEDITW WHICHEDITW ZORCHEDITW)
(FNS BUFSELP EDITWINDOWP GETLEFT GETMEBP INTAILOF TAILOF DOTTEDEND GETME4 GETSELMAP DEARME
DPCDRSEL GETDPME GETEBUF GETEDITCHAIN GETMAP GETMAP? PURGEMAP PURGEDP SUBSELOF
SETDEDITMAP TAKEDOWN)
(FNS DEDITRESHAPEFN DEDITSCROLLFN DEDITREPAINTFN)
(FNS SETEDITMENU CACHEDEDITCOMS DEFDEDITCOM FINDEDITCOM READEDITMENU SHADEMENUENTRY
DEDITMENURESTORE)
(FNS RESETDEDIT DEDITDATE DEDITMARKASCHANGED)
(FNS DEDITResetTypeComs DEDITTYPEDCOM)
(FNS COPYCONS MAPENTRYP THELIST)
(FNS CANT)
(DECLARE: DOEVAL@COMPILE DONTCOPY (RECORDS STACK)
(MACROS EDITBLOCKCALL))
(GLOBALVARS DEditWindow \DEDITMNUW \DEDITBUFW \DEDITALLOWSELS \DEDITWINDOWS \DEDITSELECTIONS)
(GLOBALVARS \DEDITTYPECOMS DEditTypedCom DEDITTTBL DEDITRDTBL)
(ALISTS (DEDITTYPEINCOMS F S Z))
(SPECVARS ATM EDITCHANGES EDITHIST LASTAIL UNDOLST UNDOLST1)
(INITVARS (DEditLinger T))
(CONSTANTS (LINETHICKNESS 2)
(PRIMSHADE 65535)
(SECSHADE 3598)
(SWITCHSHADE (LOGXOR PRIMSHADE SECSHADE))
(READSHADE 23130)
(CHANGEDSHADE 8840))
(FILES DSPRINTDEF NEWPRINTDEF)
(P (AND (GETD (QUOTE RESETDEDIT))
(RESETDEDIT)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA EP EV EF DC DP DV DF)
(NLAML)
(LAMA CANT])
(DEFINEQ
(DF
[NLAMBDA FN (* bas: "21-MAR-83 20:19")
(DEDITIT (QUOTE EDITF)
FN
(QUOTE DISPLAY])
(DV
[NLAMBDA VAR (* bas: "21-MAR-83 20:20")
(DEDITIT (QUOTE EDITV)
VAR
(QUOTE DISPLAY])
(DP
[NLAMBDA ATOM (* bas: "22-MAR-83 04:41")
(DEDITIT (QUOTE EDITPROP)
(MKLIST ATOM)
(QUOTE DISPLAY])
(DC
[NLAMBDA FILE (* bas: "21-MAR-83 20:43")
(* Edits commands of file FILE)
(DEDITIT (QUOTE EDITV)
(if (HASDEF (SETQ FILE (OR (CAR (LISTP FILE))
FILE))
(QUOTE FILE)
NIL T)
then (FILECOMS FILE)
else (ERROR FILE "is not a loaded file" T))
(QUOTE DISPLAY])
(EF
[NLAMBDA FN (* bas: "21-MAR-83 20:19")
(DEDITIT (QUOTE EDITF)
FN
(QUOTE TELETYPE])
(EV
[NLAMBDA VAR (* bas: "21-MAR-83 20:20")
(DEDITIT (QUOTE EDITV)
VAR
(QUOTE TELETYPE])
(EP
[NLAMBDA ATOM (* bas: "22-MAR-83 04:40")
(DEDITIT (QUOTE EDITPROP)
(MKLIST ATOM)
(QUOTE TELETYPE])
(EDITPROP
[LAMBDA (NAME PROP) (* bas: "21-MAR-83 20:29")
(if PROP
then (EDITDEF (LIST NAME PROP)
(QUOTE PROPS))
else (APPLY (QUOTE EDITP)
NAME])
(EDITMODE
[LAMBDA (NEWMODE) (* bas: "18-MAR-83 15:01")
(PROG [(OLDMODE (if (EQP (GETD (QUOTE EDITL))
(GETD (QUOTE DEDITL)))
then (QUOTE DISPLAY)
else (QUOTE TELETYPE]
(AND (EQ NEWMODE (QUOTE STANDARD))
(SETQ NEWMODE (QUOTE TELETYPE))) (* Obselete terminology)
(AND NEWMODE (NEQ NEWMODE OLDMODE)
(/PUTD (QUOTE EDITL)
(GETD (SELECTQ NEWMODE
(TELETYPE (QUOTE NORMAL/EDITL))
(DISPLAY (QUOTE DEDITL))
(\ILLEGAL.ARG NEWMODE)))
T))
(RETURN OLDMODE])
(DEDITIT
[LAMBDA (EFN EARGS EMODE) (* bas: "21-MAR-83 20:38")
(RESETFORM (EDITMODE EMODE)
(APPLY EFN EARGS])
)
(DEFINEQ
(DEDITL
[LAMBDA (L COMS ATM MESS EDITCHANGES) (* bas: "19-JUN-83 23:58")
(* Value is edit push-down list L.
EDITCHANGES is used for destructively marking whether
the edit made any changes.)
(RESETLST (RESETSAVE \DEDITSELECTIONS (create STACK))
(if COMS
then (RESETSAVE EDITMACROS (CONS (QUOTE (TTY: NIL (E (DEDITTTYFN ATM TYPE)
T)))
EDITMACROS))
(NORMAL/EDITL L COMS ATM MESS EDITCHANGES)
else (AND MESS (printout PROMPTWINDOW .TAB0 0 MESS T))
(PROG [MARKLST UNDOLST UNDOLST0 UNDOLST1 UNFIND LASTAIL TMP
(EXPR (CAR (LAST L]
(* EXPR is the top level expression. L is usually a list of only one element, i.e. you usually start editing at
the top, but not necessarily, since editl can be called directly.)
(if [OR (EQ EXPR (GETPROP (QUOTE EDIT)
(QUOTE LASTVALUE)))
[AND ATM (EQ EXPR (SETQ TMP (GETPROP ATM (QUOTE EDIT-SAVE]
(SOME (CAR LISPXHISTORY)
(FUNCTION (LAMBDA (X)
(EQ EXPR (SETQ TMP (CADR (MEMB (QUOTE EDIT)
X]
then
(* First clause is old method of always saving last call on editor property list. Second clause searches history
list for a call to editor corresponding to this expression.)
(SETQ MARKLST (CADR TMP))
(SETQ UNDOLST (CADDR TMP))
(if (CAR UNDOLST)
then (* Don't want to block it twice.)
(push UNDOLST NIL))
(SETQ UNDOLST0 UNDOLST)
(* Marks UNDOLST as of this entry to editor, so UNDO of
this entire EDIT session won't go too far back.)
(SETQ UNFIND (CDDDR TMP)))
(if (PROG1 (DEDITL0 EXPR (GETEDITW ATM (AND (BOUNDP (QUOTE TYPE))
TYPE)))
(* Even if some error occurs, still want to move undo
information to LISPXHISTORY.)
[if UNDOLST1
then (push UNDOLST (CONS T (CONS \DEDITSELECTIONS UNDOLST1]
(AND LISPXHIST (NEQ UNDOLST UNDOLST0)
(UNDOSAVE (LIST (QUOTE DUNDOEDITL)
\DEDITSELECTIONS UNDOLST UNDOLST0)
LISPXHIST))
(* Makes entire DEDITL undoable.)
)
then (* Normal OK exit)
(AND ATM (LITATOM ATM)
(REMPROP ATM (QUOTE EDIT-SAVE)))
[SETQ TMP (CONS EXPR (CONS MARKLST (CONS UNDOLST (LIST EXPR]
(PUTPROP (QUOTE EDIT)
(QUOTE LASTVALUE)
TMP)
(if LISPXHIST
then (NCONC LISPXHIST (LIST (QUOTE EDIT)
TMP)))
else (ERROR!)))
L])
(DEDITL0
[LAMBDA (EXPR EDS SEL) (* bas: "21-MAR-83 19:43")
(* DEDITL0 should only be called while under DEDITL or DEDITTTYFN since the global states of the edit are all
bound there. Note that individual calls to DEDITL0 are not undoable, because structure changes are saved on
UNDOLST1 and only moved to UNDOLST at the end of each command. DEDITL finally moves UNDOLST to LISPXHISTORY.)
(RESETSAVE NIL (LIST (QUOTE SETCURSOR)
(CURSOR WAITINGCURSOR)))
(if [PROG ((PM (GETMAP? EDS)))
(RETURN (AND PM (EQ EXPR (CAR (fetch TAIL of PM]
then (TOTOPW EDS) (* It may otherwise remain closed)
else (SETDEDITMAP EDS (LIST EXPR)))
(AND SEL (PUSHEDITCHAIN SEL)) (* Following ERSETQ to prevent UNDOLST lossage due to
↑E)
(ERSETQ (bind EDITHIST COM ACT SS
do (until (SETQ COM (BSELECT EDS)))
(SETQ SS \DEDITSELECTIONS) (* Save selection stack)
(SETQ ACT (CDR COM)) (* Unpack CONS from READEDITMENU)
(SETQ COM (CAR COM))
(if EDITHISTORY
then (if (PROG1 (AND ATM (NOT EDITHIST))
(* First time thru)
(EDITBLOCKCALL EDITSAVE COM)
(* Sets EDITHIST)
)
then (LISPXPUT (QUOTE *FIRSTPRINT*)
(LIST (QUOTE EDITL2)
ATM T)
NIL EDITHIST)))
(SETQ UNDOLST1 NIL) (* Holds any changes from execution of this command.)
(if (PROG1 (ERSETQ (if (LITATOM ACT)
then (APPLY* ACT)
else (EVAL ACT)))
[if UNDOLST1
then (REPPCHANGES UNDOLST1)
(push UNDOLST (SETQ UNDOLST1 (CONS COM (CONS SS UNDOLST1]
(if EDITHIST
then (* Set in EDITSAVE.)
(RPLACA EDITHIST UNDOLST1)))
else (* Restore selections)
(SETQ \DEDITSELECTIONS SS)) (* Only way out is a RETFROM via one of the exit fns)
])
(DEDITTTYFN
[LAMBDA (NAME TYPE) (* bas: " 7-AUG-83 16:38")
(* Provides DEDIT interface to TTY: commands from under
standard editor)
(DECLARE (USEDFREE L LASTAIL)) (* From EDITL0)
(PROG [UNDOLST TEM (TE (CAR (LAST L]
[RESETLST (* The RESETLST is for DEDITL0;
the binding of UNDOLST1 protects the containing EDIT;
TEM=T unless DEDITL0 was STOPed)
(PROG (UNDOLST1)
(SETQ TEM (DEDITL0 TE (GETEDITW NAME TYPE)
L]
(AND UNDOLST (push UNDOLST1 (CONS (QUOTE GROUPED)
UNDOLST)))
(if TEM
then [SETQ L (OR (AND (SUBSELOF TE (TOPSELECTION T))
(GETEDITCHAIN (TOPSELECTION T)))
(for I on L thereis (AND (SUBSELOF TE (CAR I))
(SETQ LASTAIL (CAR I]
(* Reset edit chain only if current selection still
points to some part of the expression being edited)
elseif [EVALV (QUOTE COMS)
(SETQ TEM (STKPOS (QUOTE EDITL0]
then (RETEVAL TEM (QUOTE (ERROR!))
T)
else (SHOULDNT])
)
(DEFINEQ
(DEDITAfter
[LAMBDA NIL (* bas: "17-MAR-83 22:15")
(PROG ([NU (COPY (CAR (POPSELECTION]
(TGT (POPSELECTION)))
(DEDITZAPCDR TGT (PUSHSELECTION (if (DPCDRSEL TGT)
then (DEDITCONS (CDR TGT)
NU TGT)
else (DEDITCONS NU (CDR TGT)
TGT])
(DEDITBefore
[LAMBDA NIL (* bas: "16-MAR-83 12:40")
(PROG ((SRC (POPSELECTION))
(TGT (POPSELECTION)))
(PUSHSELECTION (SETPTRTO TGT (DEDITCONS (COPY (CAR SRC))
(if (DPCDRSEL TGT)
then (CDR TGT)
else TGT)
TGT])
(DEDITDelete
[LAMBDA NIL (* bas: "16-MAR-83 11:51")
(* Deletes top elt from structure.
Pushes it back on into the buffer)
(PROG ((S (POPSELECTION)))
[PUSHINTOBUF (LIST (COPY (CAR S] (* Copy keeps structure in buffer separate from that on
undolst, which may later get inserted back)
(SETPTRTO S (if (DPCDRSEL S)
then NIL
else (CDR S])
(DEDITReplace
[LAMBDA NIL (* bas: " 5-JUL-83 23:50")
(PROG ((SRC (POPSELECTION))
(TGT (TOPSELECTION)))
(DEDITZAPCAR TGT (SUBST (CAR TGT)
(OR EDITEMBEDTOKEN (CONSTANT (PACK NIL)))
(CAR SRC])
(DEDITSwitch
[LAMBDA NIL (* bas: "16-MAR-83 21:05")
(PROG ((A (TOPSELECTION))
(B (NXTSELECTION)))
(if (OR (DOMINATE? A B)
(DOMINATE? B A))
then (CANT "Switch into oneself"))
(DEDITZAPCAR A (PROG1 (CAR B)
(DEDITZAPCAR B (CAR A])
(DEDITBI
[LAMBDA NIL (* bas: "16-MAR-83 11:51")
(PROG ((A (POPSELECTION))
(B (POPSELECTION))
C)
(if (TAILOF B A)
elseif (TAILOF A B)
then (SETQ A (PROG1 B (SETQ B A)))
else (CANT "Not brothers!"))
(if (DPCDRSEL B)
else (SETQ C (CDR B)) (* Done in this order in case A=B)
(DEDITZAPCDR B NIL))
(DEDITZAPBOTH A (COPYCONS A)
C)
(PUSHSELECTION A])
(DEDITBO
[LAMBDA NIL (* bas: "16-MAR-83 21:01")
(PROG ((TGT (POPSELECTION)))
(AND (CDR TGT)
(DEDITNCONC TGT (CDR TGT)))
(SETPTRTO TGT (CAR TGT])
(DEDITLI
[LAMBDA NIL (* bas: " 2-MAR-83 11:33")
(PROG ((A (TOPSELECTION)))
(DEDITZAPBOTH A (COPYCONS A])
(DEDITLO
[LAMBDA NIL (* bas: " 2-MAR-83 11:34")
(PROG ((A (TOPSELECTION)))
(DEDITZAPNODE A (THELIST (CAR A])
(DEDITRI
[LAMBDA NIL (* bas: " 2-MAR-83 12:03")
(PROG (B (A (POPSELECTION)))
[SETQ B (fetch TAIL of (GETMEBP (GETME4 A T]
(DEDITNCONC B (CDR B))
(DEDITZAPCDR B (CDR A))
(DEDITZAPCDR A NIL)
(PUSHSELECTION B])
(DEDITRO
[LAMBDA NIL (* bas: " 2-MAR-83 11:34")
(PROG ((A (TOPSELECTION)))
(DEDITNCONC A (CDR A))
(DEDITZAPCDR A NIL])
(DEDITUndo
[LAMBDA (END) (* bas: "20-AUG-82 11:31")
(bind FLG for LST on UNDOLST unless (SELECTQ (CAAR LST)
((NIL !Undo UnBlock)
T)
(Undo END)
NIL)
do (DUNDOEDITCOM (CAR LST)
T)
(OR END (RETURN))
(SETQ FLG T)
repeatuntil (OR (EQ END (CAR LST))
(NULL (CAR LST)))
finally (OR FLG (CANT (if (CDR LST)
then "Undo blocked"
else "Nothing saved"])
(UNDOCHOOSE
[LAMBDA (THRUP) (* bas: "20-AUG-82 12:10")
(PROG (C)
(OR UNDOLST (CANT "Nothing to Undo"))
(OR [SETQ C (RESETFORM (CURSOR DEFAULTCURSOR)
(MENU (create MENU
ITEMS ←(APPEND
(for I in UNDOLST
collect (LIST (OR (CAR I)
(PACK* "* " (CADR I)
" *"))
(LIST (QUOTE QUOTE)
I)))
(LIST (LIST (QUOTE **TOP**)
NIL)))
TITLE ←(if THRUP
then "Undo Thru"
else "Undo One")
CENTERFLG ← T]
(RETURN))
(if THRUP
then (DEDITUndo C)
else (DUNDOEDITCOM C T])
(DEDITFind
[LAMBDA NIL (* bas: " 2-MAR-83 11:35")
(PROG (LASTAIL L TGT UNFIND (COM (QUOTE Find)))
(DECLARE (SPECVARS L UNFIND COM))
(SETQ L (GETEDITCHAIN (POPSELECTION))) (* Sets LASTAIL)
(SETQ TGT (CAR (TOPSELECTION)))
(if [ERSETQ (RESETVARS (UPFINDFLG)
(EDIT4F TGT (QUOTE N]
then (PUSHEDITCHAIN L LASTAIL)
else (CANT TGT "Not found"])
(DEDITSwap
[LAMBDA NIL (* bas: "24-MAR-83 15:57")
(replace TOPELT of \DEDITSELECTIONS with (PROG1 (NXTSELECTION)
(replace NXTELT of \DEDITSELECTIONS
with (TOPSELECTION])
(DEDITCenter
[LAMBDA (NOTIFVIS) (* bas: "30-MAR-83 22:18")
(PROG ((A (GETME4 (TOPSELECTION)))
AW)
(OR A (RETURN))
(SETQ AW (WFROMDS (fetch PDSP of A)))
(AND NOTIFVIS (IGREATERP (fetch STARTY of A)
(WYOFFSET NIL AW))
[ILESSP (fetch STOPY of A)
(IPLUS (WYOFFSET NIL AW)
(WINDOWPROP AW (QUOTE HEIGHT]
(RETURN))
(SCROLLBYREPAINTFN AW 0 (IDIFFERENCE (IPLUS (WYOFFSET NIL AW)
(IQUOTIENT (IDIFFERENCE (WINDOWPROP
AW
(QUOTE HEIGHT))
(IDIFFERENCE
(fetch STARTY
of A)
(fetch STOPY
of A)))
2))
(fetch STOPY of A])
(DEDITCopy
[LAMBDA NIL (* bas: " 2-MAR-83 11:37")
(PUSHINTOBUF (LIST (COPY (CAR (TOPSELECTION])
(DEDITReprint
[LAMBDA NIL (* bas: " 2-MAR-83 11:37")
(REPP (GETME4 (TOPSELECTION)
T])
(DEDITCEdit
[LAMBDA (E) (* bas: "30-MAR-83 10:09")
(if (FGETD (QUOTE TTYINEDIT))
then (PROG [(V (TTYINEDIT E (GETEBUF NIL]
(OR (BUFSELP (GETME4 (TOPSELECTION)))
(BUFSELP (GETME4 (NXTSELECTION T)))
(SETDEDITMAP (GETEBUF T)
(COPY V)))
(RETURN V))
else (CANT "TTYIN not loaded"])
(DEDITEdit
[LAMBDA (EDITOR EDITEE) (* rrb "12-AUG-83 10:35")
(RESETLST (RESETSAVE (SETCURSOR DEFAULTCURSOR)
(LIST (QUOTE SETCURSOR)
WAITINGCURSOR))
(PROG (A S)
(SELECTQ EDITEE
((Def NIL)
(for old (S ←(POPSELECTION)) by (CAR S) while (LISTP S))
(if (NOT (LITATOM S))
then (INSPECT S)
elseif (AND (SETQ A (TYPESOF S NIL NIL (QUOTE ?)))
(SETQ A (SELECT.ATOM.ASPECT S NIL A)))
then (RESETSAVE (EDITMODE EDITOR))
(* User can refuse all SELECT.ATOM.ASPECT choices)
(EDITDEF S A (QUOTE ?))
else (CANT "No editable aspect")))
[Form (AND [SETQ S (APPLY* (if (EQ EDITOR (QUOTE TTYIn))
then (QUOTE DEDITCEdit)
else (RESETSAVE (EDITMODE EDITOR))
(QUOTE EDITE))
(LIST (COPY (CAR (TOPSELECTION]
(DEDITZAPCAR (TOPSELECTION)
(CAR S]
(SHOULDNT])
(DEDITEditCom
[LAMBDA (C) (* bas: "30-MAR-83 20:55")
[OR C (SETQ C (CAR (POPSELECTION]
(PROG (TYPE ATM EDITCHANGES LASTAIL LASTP1 LASTP2 TSM SCR (TS (POPSELECTION)))
(DECLARE (SPECVARS TYPE ATM EDITCHANGES LASTAIL LASTP1 LASTP2))
(* For DEDITL and EDITL0)
[if (SETQ TSM (GETME4 TS))
then (if (SETQ SCR (WINDOWPROP (fetch PDSP of TSM)
(QUOTE DEDITWHOAMI)))
then (SETQ ATM (CAR SCR))
(SETQ TYPE (CADR SCR)))
(SETQ EDITCHANGES (WINDOWPROP (fetch PDSP of TSM)
(QUOTE DEDITCHANGES]
(PUSHEDITCHAIN (EDITL0 (GETEDITCHAIN TS)
(MKLIST C])
(DEDITARGS
[LAMBDA (F) (* bas: "30-MAR-83 16:14")
(SETQ F (OR F (TOPSELECTION)))
(while (LISTP F) do (SETQ F (CAR F)))
(PUSHINTOBUF (LIST (CONS F (COPY (OR [AND (LITATOM F)
(CAR (NLSETQ (SMARTARGLIST F T]
(QUOTE (not a function])
(DEDITBreak
[LAMBDA NIL (* bas: " 7-MAR-83 12:01")
(PROG (WHO AMP CARFORM (A (POPSELECTION)))
(SETQ AMP (GETME4 A))
[SETQ WHO (AND AMP (WINDOWPROP (fetch PDSP of AMP)
(QUOTE DEDITWHOAMI]
(* * WT packs on BREAKINCHAR to these atoms and UNBREAK wont work without them)
(DEDITZAPCAR A (LIST (QUOTE BREAK1)
(CAR A)
T
(LIST (PACK* (CAR WHO)
BREAKINCHAR)
(PACK* (QUOTE around)
BREAKINCHAR)
(PACK* (SETQ CARFORM (OR (NLISTP (CAR A))
(CAAR A)))
BREAKINCHAR))
NIL))
(OR [if AMP
then (AND (fetch BP of AMP)
(FMEMB (CAAR (fetch TAIL of (fetch BP of AMP)))
NOBREAKS)
(PROMPTPRINT "Break installed inside a NOBREAKS"))
(if (EQ (CADR WHO)
(QUOTE FNS))
then (/PUTPROP (CAR WHO)
(QUOTE BROKEN-IN)
T)
(/PUTPROP (CAR WHO)
(QUOTE BRKINFO)
(LIST (LIST (LIST (QUOTE AROUND)
CARFORM)
NIL NIL)))
(/SET (QUOTE BROKENFNS)
(CONS (CAR WHO)
BROKENFNS]
(PROMPTPRINT "Break installed, but not recorded"])
(DEDITEval
[LAMBDA NIL (* bas: "25-MAR-83 16:23")
(PROG [(S (CAR (POPSELECTION]
(PUSHINTOBUF (if (LITATOM S)
then (LIST (EVALV S))
elseif (ERSETQ (LISPXEVAL S NIL))
else (LIST (QUOTE NOBIND])
(DEDITExit
[LAMBDA (STOPFLG) (* bas: " 9-OCT-82 17:24")
(AND EDITHIST ATM (NOT STOPFLG)
(LISPXPUT (QUOTE *PRINT*)
(LIST (QUOTE EDITL2)
ATM)
NIL EDITHIST)) (* Hoaky stuff for the edit history list)
(RETFROM (QUOTE DEDITL0)
(NOT STOPFLG)
T])
)
(DEFINEQ
(SETPTRTO
[LAMBDA (X Y) (* bas: "16-MAR-83 13:23")
(PROG ((XM (GETME4 X T))
BK TEM)
(if [SETQ TEM (GETLEFT XM (SETQ BK (GETMEBP XM]
then (DEDITZAPCDR TEM Y)
elseif (fetch BP of BK)
then (DEDITZAPCAR BK Y)
elseif (NLISTP Y)
then (CANT "Delete last list element")
else (DEDITZAPBOTH X (CAR Y)
(if (EQ X (CDR Y))
then (RPLNODE2 Y X)
else (CDR Y)))
(SETQ Y X))
(RETURN Y])
(DEDITCONS
[LAMBDA (A D BROTHER) (* bas: "25-MAR-83 17:12")
(fetch TAIL of (DUMMYMAPENTRY (CONS A D)
(GETMEBP (OR (GETME4 BROTHER)
(CANT "Invalid target"])
(DEDITZAPCAR
[LAMBDA (M A) (* bas: " 2-MAR-83 15:38")
(DEDITZAPBOTH M A (CDR (OR (LISTP M)
(fetch TAIL of M])
(DEDITZAPCDR
[LAMBDA (M D) (* bas: "25-JUL-82 16:23")
(DEDITZAPBOTH M (CAR (OR (LISTP M)
(fetch TAIL of M)))
D])
(DEDITZAPNODE
[LAMBDA (M C) (* bas: "27-JUL-81 04:48")
(DEDITZAPBOTH M (CAR C)
(CDR C])
(DEDITZAPBOTH
[LAMBDA (CC A D ENT) (* bas: "30-MAR-83 23:17")
(* ALL edit changes go through this function.)
(if (SETQ ENT (if (type? DEDITMAP CC)
then (PROG1 CC (SETQ CC (fetch TAIL of CC)))
else (GETME4 CC)))
then (if (fetch BP of ENT)
elseif (BUFSELP ENT)
elseif (AND (EQ D (CDR CC))
(LISTP (CAR CC))
(LISTP A))
then (* Ideally should check that CC cannot be reached from A
b/c in this case this trick is not valid)
(SETQ D (CDR A))
(SETQ A (CAR A))
(SETQ CC (CAR CC))
else (CANT "Alter top"))
[if (DPCDRSEL ENT)
then [SETQ CC (LAST (fetch SELEXP of (fetch BP of ENT]
(* Real CONS)
(SETQ D (if (NEQ A (CDR CC))
then A
else D))
(SETQ A (CAR CC))
(PROG ((V (DOTTEDEND D)))
(if V
then (DEDITFZAP (fetch TAIL of ENT)
V V)
else (PUTHASH (fetch TAIL of (fetch BP of ENT))
NIL \DEDITDPHASH)
(PUTHASH (fetch TAIL of ENT)
NIL \DEDITMEHASH]
(AND EDITSMASHUSERFN (APPLY* EDITSMASHUSERFN CC (GETEDITCHAIN ENT)))
[if (DEDITFZAP CC A D)
then [PROG [(TEM (CDR (WINDOWPROP (fetch PDSP of ENT)
(QUOTE DEDITCHANGES]
(* Undoably smashes EDITCHANGES from call in which
change is being made, unless already set)
(OR (NOT TEM)
(CAR TEM)
(DEDITFZAP TEM T (CDR TEM]
(AND CHANGESARRAY (DEDITZAPCHANGES ENT))
(* A smashed cell is always changed)
(for (E ← ENT) by (fetch BP of E) while E do (DEDITZAPCLISP (fetch SELEXP
of E]
else (AND EDITSMASHUSERFN (APPLY* EDITSMASHUSERFN CC (LIST CC)))
(DEDITFZAP CC A D])
(DEDITFZAP
[LAMBDA (CC A D) (* bas: "30-MAR-83 23:16")
(* Smashes cons CC and makes UNDOLST entry but uses no other context. Used for making changes to editor structures
sauch as the undo list itself)
(PROG ((OA (CAR CC))
(OD (CDR CC))) (* Dont smash EQ values. Slow b/c of refcnts and
clutters up UNDOLST)
(RETURN (AND (if (EQ D OD)
then (AND (NEQ A OA)
(FRPLACA CC A))
elseif (EQ A OA)
then (FRPLACD CC D)
else (RPLNODE CC A D))
(push UNDOLST1 (CONS CC (CONS OA OD])
(DEDITZAPCLISP
[LAMBDA (CC) (* bas: "30-MAR-83 23:01")
(* Deletes CLISP translation. Not made part of the edit event, because of the possibility of the user performing
two changes, and then undoing the first, which would then restore the translation, even though it no longer
corresponds to the untranslated and changed CLISP.)
(if (NLISTP CC)
elseif (AND CLISPTRANFLG (EQ CLISPTRANFLG (CAR CC)))
then (if (LISTP (CDDR CC))
then (/RPLNODE2 CC (CDDR CC))
else (* CLISP% used to translate an atom e.g. QLISP does
this.)
(SHOULDNT))
elseif (AND CLISPARRAY (GETHASH CC CLISPARRAY))
then (/PUTHASH CC NIL CLISPARRAY])
(DEDITZAPCHANGES
[LAMBDA (ME) (* bas: "18-OCT-81 22:29")
(if (for (I ← ME) by (fetch BP of I) while I never (GETHASH (fetch TAIL of I)
CHANGESARRAY))
then [push UNDOLST1 (CONS (QUOTE LISPXHIST)
(LIST (LIST (QUOTE /PUTHASH)
(fetch TAIL of ME)
(GETHASH (fetch TAIL of ME)
CHANGESARRAY)
CHANGESARRAY]
(* Done this way for efficiency rather than going
through editcom1 since we know what to undosave.)
(PUTHASH (fetch TAIL of ME)
ATM CHANGESARRAY])
(DEDITNCONC
[LAMBDA (X Y) (* bas: " 2-MAR-83 11:41")
(DEDITZAPCDR (LAST (THELIST (CAR X)))
Y])
(DUNDOEDITL
[LAMBDA (SS ULST ULST0) (* bas: "24-MAR-82 12:06")
(PROG (UNDOLST1 WAI)
(for X on ULST until (EQ X ULST0) do (DUNDOEDITCOM (CAR X)) when (CAR X))
(OR UNDOLST1 (SHOULDNT)) (* Must have some changes to undo)
[bind TMP for I in ULST when [for J in (CDDDR I) thereis (SETQ TMP (WHICHEDITW
(CAR J]
do (AND (SETQ TMP (WINDOWPROP TMP (QUOTE DEDITWHOAMI)))
(MARKASCHANGED (CAR TMP)
(CADR TMP]
(DEDITFZAP ULST (CAR ULST0)
(CDR ULST0)) (* So undo can be UNDOne.)
(if LISPXHIST
then (UNDOSAVE [LIST (QUOTE DUNDOEDITL)
SS
(LIST (CONS T (CONS SS UNDOLST1]
LISPXHIST])
(DUNDOEDITCOM
[LAMBDA (X FLG) (* bas: "21-MAR-83 19:43")
(* If FLG is T, name of command is printed.)
(if (NLISTP X)
then (CANT "Garbage on DEDIT UNDO list")
(* Used to elseif (AND (CADR X) (NOT (SAMEEXPR MAP (fetch TOPELT of (CADR X))))) then (* The saved
\DEDITSELECTIONS was not from the edit expression) (CANT "UNDO on different expression"))
elseif (CAR X)
then (DUNDOEDITCOM1 X) (* else has been undone before, dont UNDO it again.)
)
(if FLG
then (SETQ \DEDITSELECTIONS (CADR X))
(printout PROMPTWINDOW T (OR (CAR X)
"Already")
" undone."))
(DEDITFZAP X NIL (COPYCONS X)) (* Marks X so UNDO will skip it in future.
UNDOing this UNDO will unmark it)
T])
(DUNDOEDITCOM1
[LAMBDA (C) (* bas: "21-MAR-83 19:43")
(* Takes a single entry on UNDOLST, i.e. list of the form (command-name \DEDITSELECTIONS . UNDOLST1) and maps down
the UNDOLST1 portion performing the corresonding DEDITSMASHes.)
(for X in (CDDR C) do (SELECTQ (CAR X)
(GROUPED (* Used by TTY: command, which must add entire UNDOLST
from subordinate call to EDITL0 to its own UNDOLST1.)
(for X in (CDR X) do (DUNDOEDITCOM1 X)))
(LISPXHIST (EDITBLOCKCALL EDITCOM1 (CDR X)))
(DEDITZAPNODE (CAR X)
(CDR X])
)
(DEFINEQ
(BSELECT
[LAMBDA (CDS) (* bas: "30-MAR-83 19:50")
(* Does selections until a command is given)
(RESETFORM (DEDITUSER (WFROMDS CDS))
(CAR (ERSETQ (bind TMP MENUMOVED
do (OR (WINDOWP \DEDITMNUW)
(SETEDITMENU CDS))
(GETMOUSESTATE)
[if [EQ MENUMOVED (SETQ MENUMOVED (KEYDOWNP (QUOTE TAB]
elseif MENUMOVED
then [MOVEW \DEDITMNUW (ADD1 LASTMOUSEX)
(IDIFFERENCE LASTMOUSEY (WINDOWPROP \DEDITMNUW
(QUOTE YOFFSET]
(OR (READP T)
(DISMISS 20))
(* Wait til TAB read)
(CLEARBUF T)
else (MOVEW \DEDITMNUW (WINDOWPROP \DEDITMNUW (QUOTE HOME]
(AND [SETQ TMP (OR (AND (READP T)
(SELECTKEYS))
(AND (INWINDOW (TOTOPW \DEDITMNUW))
(READEDITMENU]
(RETURN TMP))
(\BACKGROUND])
(DEDITUSER
[LAMBDA (DS) (* bas: "24-MAR-83 15:04")
(PROG1 (if DS
then NIL
elseif (TOPEDITW))
(if (SETQ \DEDITALLOWSELS (WINDOWP DS))
then (TOTOPW DS)
(SETEDITMENU DS))
(AND \DEDITSELECTIONS (FLIPSELS))
(SETCURSOR (if DS
then DEFAULTCURSOR
else WAITINGCURSOR])
(SELECTKEYS
[LAMBDA NIL (* bas: "30-MAR-83 20:34")
(PROG [(NUV (ERSETQ (RESETLST (RESETSAVE (TTYDISPLAYSTREAM (GETEBUF NIL)))
(RESETSAVE \DEDITALLOWSELS NIL)
(RESETSAVE NIL (LIST (QUOTE SETREADTABLE)
(SETREADTABLE DEDITRDTBL T)
T))
(RESETSAVE (SETTERMTABLE DEDITTTBL))
(while (READP T) collect (APPLY* LISPXREADFN T T)
finally (RETURN (if (CDR $$VAL)
then $$VAL
else (CAR $$VAL]
(* GETEBUF of NIL returns an inactive window.)
(if (NLISTP NUV)
elseif (EQ DEditTypedCom (CAAR NUV))
then (RETURN (DEDITTYPEDCOM (CDAR NUV)))
else (SHADEIFNOTBUF (NXTSELECTION T)
SECSHADE) (* Push shading)
(SHADEIFNOTBUF (TOPSELECTION T)
SWITCHSHADE)
(SHADESELECTION (SETDEDITMAP (GETEBUF T)
(PUSHSELECTION NUV))
PRIMSHADE])
(SHADEIFNOTBUF
[LAMBDA (X TXT) (* bas: "13-MAR-83 19:59")
(AND X (SETQ X (GETSELMAP X))
(NOT (BUFSELP X))
(SHADESELECTION X TXT])
(DEDITBUTTONFN
[LAMBDA (W) (* bas: "18-MAR-83 16:50")
(TOTOPW W) (* Bring it up, if nothing else)
(AND (EDITWINDOWP W)
(if (OR (KEYDOWNP (QUOTE LSHIFT))
(KEYDOWNP (QUOTE RSHIFT)))
then (SELECTREAD W)
elseif \DEDITALLOWSELS
then (SELECTELEMENT W])
(DEDITRIGHTBUTTONFN
[LAMBDA (W) (* bas: "21-MAR-83 11:18")
(if (AND (EDITWINDOWP W)
(INWINDOW W)
\DEDITALLOWSELS)
then (SELECTTREE)
else (DOWINDOWCOM W])
(SELECTELEMENT
[LAMBDA (DS) (* bas: "24-MAR-83 16:01")
(bind N M (TE ←(GETSELMAP (TOPSELECTION T)))
(NE ←(GETSELMAP (NXTSELECTION T))) until (SELECTDONE DS)
do (AND (SETQ M (SEARCHMAP DS))
(LASTMOUSESTATE MIDDLE)
(SETQ M (fetch BP of M)))
(if (EQ M N)
else (if (AND N M)
else (SHADESELECTION NE SECSHADE) (* Virtual push/pop)
(SHADESELECTION TE SWITCHSHADE))
(SHADESELECTION N PRIMSHADE)
(SHADESELECTION M PRIMSHADE)
(SETQ N M))
finally (AND M (PUSHSELECTION (fetch TAIL of M])
(SELECTREAD
[LAMBDA (DS) (* bas: "18-MAR-83 16:50")
(bind M N while (KEYDOWNP (QUOTE LSHIFT)) do (until (SELECTDONE DS)
do (AND (SETQ M (SEARCHMAP DS))
(LASTMOUSESTATE MIDDLE)
(SETQ M (fetch BP of M)))
(if (AND N M)
then (if (EQ M N)
else (SHADESELECTION N READSHADE)
(SHADESELECTION M READSHADE))
else (SHADESELECTION (OR N M)
READSHADE))
(SETQ N M))
finally (if M
then (SHADESELECTION M READSHADE)
(\MAPCHARS (FUNCTION \PUTSYSBUF)
(fetch SELEXP of M)
T)
(OR (LISTP (fetch SELEXP of M))
(\PUTSYSBUF (CHARCODE SPACE])
(SELECTTREE
[LAMBDA NIL (* bas: " 2-MAR-83 11:38")
(bind N DS (OT ←(GETME4 (TOPSELECTION)
T))
first (SETQ DS (fetch PDSP of OT)) until (SELECTDONE DS)
do (SWITCHANDSHADE (if (SETQ N (SEARCHMAP DS))
then (FINDLCA OT N)
else OT])
(SEARCHMAP
[LAMBDA (PDS) (* bas: "17-MAR-83 13:00")
(PROG (L S (E (GETMAP PDS))
(LX (LASTMOUSEX PDS))
(LY (LASTMOUSEY PDS)))
[while E until (AND (WITHINME E LX LY)
(OR [NOT (SETQ L (LISTP (fetch SELEXP of (SETQ S E]
(ONAPARENP E LX LY)))
do (* The until clause is true if either E covers mouse and
has no descendents or we're on a paren)
(SETQ E (GETME4 L S)) (* Either pending tail or embedded descendents to
search)
(if (AND E (fetch PURGED of E))
then (REPP S)
(SETQ E (GETME4 (fetch TAIL of S)
T))
(SETQ S (fetch BP of E))
(SETQ L (CDR (fetch TAIL of E)))
else (SETQ L (CDR (LISTP L]
(RETURN E])
(WITHINME
[LAMBDA (E X Y) (* bas: "30-MAR-83 14:24")
(PROG [(FA (FONTPROP (fetch FNT of E)
(QUOTE ASCENT)))
(FD (FONTPROP (fetch FNT of E)
(QUOTE DESCENT]
(RETURN (if (IGREATERP Y (IPLUS FA (fetch STARTY of E)))
then NIL
elseif (IGEQ Y (IDIFFERENCE (fetch STARTY of E)
FD))
then [AND (IGEQ X (fetch STARTX of E))
(OR (ILESSP X (fetch STOPX of E))
(NEQ (fetch STARTY of E)
(fetch STOPY of E]
elseif (ILESSP Y (IDIFFERENCE (fetch STOPY of E)
FD))
then NIL
elseif (IGREATERP Y (IPLUS FA (fetch STOPY of E)))
else (ILESSP X (fetch STOPX of E])
(ONAPARENP
[LAMBDA (E X Y) (* bas: "30-MAR-83 14:24")
(PROG ((EF (fetch FNT of E)))
(RETURN (OR [AND (ILESSP X (fetch LPEND of E))
(IGEQ Y (IDIFFERENCE (fetch STARTY of E)
(FONTPROP EF (QUOTE DESCENT]
(AND (IGEQ X (fetch RPSTART of E))
(ILESSP Y (IPLUS (fetch STOPY of E)
(FONTPROP EF (QUOTE ASCENT])
(SELECTDONE
[LAMBDA (PDS) (* bas: "28-JUL-82 22:42")
(OR (MOUSESTATE UP)
(NOT (INWINDOW PDS])
(INWINDOW
[LAMBDA (DS) (* bas: "27-AUG-82 12:38")
(INSIDE? (DSPCLIPPINGREGION NIL DS)
(LASTMOUSEX DS)
(LASTMOUSEY DS])
(FINDLCA
[LAMBDA (S1 S2) (* bas: "25-APR-81 17:09")
(while S1 until (DOMINATE? S1 S2) do (SETQ S1 (fetch BP of S1)) finally (RETURN S1])
(DOMINATE?
[LAMBDA (SUP SUB) (* bas: " 7-AUG-83 15:49")
(OR (EQ SUP SUB)
(PROG [(S1 (OR (MAPENTRYP SUP)
(GETME4 SUP)))
(S2 (OR (MAPENTRYP SUB)
(GETME4 SUB]
(RETURN (if S2
then (for old S2 by (fetch BP of S2) while S2 thereis (EQ S1 S2))
else (for I on (CAR (LISTP SUP)) thereis (DOMINATE? I SUB])
)
(DEFINEQ
(POPSELECTION
[LAMBDA NIL (* bas: "21-MAR-83 19:43")
(PROG1 (TOPSELECTION)
(pop \DEDITSELECTIONS])
(PUSHSELECTION
[LAMBDA (S) (* bas: "21-MAR-83 19:43")
(push \DEDITSELECTIONS S)
S])
(NXTSELECTION
[LAMBDA (NOERR) (* bas: "24-MAR-83 15:52")
(OR (fetch NXTELT of \DEDITSELECTIONS)
(AND (NOT NOERR)
(CANT "No second selection"])
(TOPSELECTION
[LAMBDA (NOERR) (* bas: "24-MAR-83 15:52")
(OR (fetch TOPELT of \DEDITSELECTIONS)
(AND (NOT NOERR)
(CANT "Too few selections"])
(SWITCHANDSHADE
[LAMBDA (NU) (* bas: "24-MAR-83 16:02")
(* Like a POP/PUSH sequence but no CONS)
(if (EQ (fetch TAIL of NU)
(TOPSELECTION T))
else (SHADESELECTION (GETME4 (TOPSELECTION T)
T)
PRIMSHADE)
(replace TOPELT of \DEDITSELECTIONS with (fetch TAIL of NU))
(SHADESELECTION NU PRIMSHADE])
(SHADESELECTION
[LAMBDA (S SHADE) (* bas: " 2-MAR-83 13:31")
(AND S (SHADESELECTION1 S SHADE])
(SHADESELECTION1
[LAMBDA (S TXT) (* bas: "30-MAR-83 14:31")
(if (EQ (fetch STARTY of S)
(fetch STOPY of S))
then (* This way mainly for efficiency)
(SHADESELECTION2 S (fetch STARTY of S)
(fetch STARTX of S)
(fetch STOPX of S)
TXT)
elseif (LISTP (CAR (fetch TAIL of S)))
then (PROG NIL
(SHADESELECTION2 S (fetch STARTY of S)
(fetch STARTX of S)
(fetch LPEND of S)
TXT)
(for E on (CAR (fetch TAIL of S)) do (SHADESELECTION1 (GETME4 E S)
TXT)
finally (if E
then (* Dotted pair)
(SHADESELECTION1 (GETME4 E S)
TXT)))
(SHADESELECTION2 S (fetch STOPY of S)
(fetch RPSTART of S)
(fetch STOPX of S)
TXT))
else (for I from (fetch STARTY of S) by (IMINUS (FONTPROP (fetch FNT of S)
(QUOTE HEIGHT)))
to (fetch STOPY of S) do (SHADESELECTION2 S I (if (EQ I (fetch STARTY of S))
then (fetch STARTX of S)
else (DSPLEFTMARGIN NIL
(fetch PDSP
of S)))
(if (EQ I (fetch STOPY of S))
then (fetch STOPX of S)
else (DSPRIGHTMARGIN NIL
(fetch PDSP
of S)))
TXT])
(SHADESELECTION2
[LAMBDA (S CY SX EX SHADE) (* bas: "13-JUL-82 10:02")
(BITBLT NIL NIL NIL (fetch PDSP of S)
SX
(IDIFFERENCE CY (ADD1 LINETHICKNESS))
(IDIFFERENCE EX SX)
LINETHICKNESS
(QUOTE TEXTURE)
(QUOTE INVERT)
SHADE])
(PUSHEDITCHAIN
[LAMBDA (C) (* bas: "30-MAR-83 22:19")
[PUSHSELECTION (PROG ((X (MAKESELCHAIN C)))
(RETURN (if (MAPENTRYP X)
then (fetch TAIL of X)
else C]
(DEDITCenter T])
(MAKESELCHAIN
[LAMBDA (LST) (* bas: "30-MAR-83 23:34")
(* Makes dummy map entries until the whole chain is linked into an extant map. This is necessary so subsequent
commands from a Multiple can find their way around)
(if (CDR (THELIST LST))
then [PROG [(TMP (OR (FMEMB (CAR LST)
(CADR LST))
(TAILP (CAR LST)
(CADR LST))
[AND (NLISTP (CAR LST))
(EQ (CAR LST)
(DOTTEDEND (CADR LST]
(CANT "Inconsistent EDIT chain"]
(RETURN (OR (GETME4 TMP)
(DUMMYMAPENTRY TMP (MAKESELCHAIN (CDR LST]
else (PROG [(Y (GETME4 (CAR LST]
(RETURN (AND (MAPENTRYP Y)
(GETMEBP Y])
(PUSHINTOBUF
[LAMBDA (V) (* bas: " 4-MAR-83 12:23")
(AND V (PUSHSELECTION V])
(DUMMYMAPENTRY
[LAMBDA (E B) (* bas: "21-MAR-83 19:58")
(PUTHASH E (create DEDITMAP
TAIL ←(OR (LISTP E)
(GETHASH (fetch TAIL of B)
\DEDITDPHASH)
(PUTHASH (fetch TAIL of B)
(CONS E E)
\DEDITDPHASH))
BP ← B
PDSP ←(fetch PDSP of B))
\DEDITMEHASH])
(FLIPSELS
[LAMBDA NIL (* bas: "24-MAR-83 16:02")
(* Turns selections on or off across possible movement)
(PROG [(TM (FIXUPSEL (TOPSELECTION T]
(SHADESELECTION TM PRIMSHADE)
(SHADESELECTION (FIXUPSEL (NXTSELECTION T)
(BUFSELP TM))
SECSHADE])
(FLIPSELSIN
[LAMBDA (DS) (* bas: "24-MAR-83 16:03")
(* Turns selections on or off across possible movement)
(SETQ DS (WINDOWPROP DS (QUOTE DSP)))
(PROG (S)
(AND (SETQ S (GETSELMAP (TOPSELECTION T)))
(EQ DS (fetch PDSP of S))
(SHADESELECTION S PRIMSHADE))
(AND (SETQ S (GETSELMAP (NXTSELECTION T)))
(EQ DS (fetch PDSP of S))
(SHADESELECTION S SECSHADE])
(FIXUPSEL
[LAMBDA (X BUFBUSY) (* bas: "13-MAR-83 20:18")
(* Returns a new selection if X is not OK)
(AND X (PROG ((TMP (GETME4 X)))
(AND TMP (if (PURGEDP TMP)
then (* Perhaps the whole window has been ZORCHed.
Try again if you can reestablish the EDITEXPR)
(AND (NOT (GETMAP? (fetch PDSP of TMP)))
(GETMAP (fetch PDSP of TMP))
(RETURN (FIXUPSEL X BUFBUSY)))
else (RETURN TMP)))
(AND (NOT BUFBUSY)
(RETURN (SETDEDITMAP (GETEBUF T)
(NEWSELFOR X])
(NEWSELFOR
[LAMBDA (X) (* bas: "24-MAR-83 16:03")
(PROG ((Y (CONS (COPY (CAR X))
NIL)))
(if (EQ X (TOPSELECTION T))
then (replace TOPELT of \DEDITSELECTIONS with Y)
elseif (EQ X (NXTSELECTION T))
then (replace NXTELT of \DEDITSELECTIONS with Y)
else (SHOULDNT))
(RETURN Y])
)
(DEFINEQ
(ACTIVEEDITW
[LAMBDA (W ONFLG) (* bas: "18-MAR-83 10:42")
(WINDOWPROP W (QUOTE BUTTONEVENTFN)
(AND ONFLG (QUOTE DEDITBUTTONFN)))
(WINDOWPROP W (QUOTE RIGHTBUTTONFN)
(if ONFLG
then (QUOTE DEDITRIGHTBUTTONFN)
else (QUOTE DOWINDOWCOM)))
(WINDOWPROP W (QUOTE RESHAPEFN)
(AND ONFLG (QUOTE DEDITRESHAPEFN)))
(WINDOWPROP W (QUOTE REPAINTFN)
(AND ONFLG (QUOTE DEDITREPAINTFN)))
(WINDOWPROP W (QUOTE SCROLLFN)
(AND ONFLG (QUOTE DEDITSCROLLFN)))
(DSPSCROLL (if ONFLG
then (QUOTE OFF)
else T)
(WINDOWPROP W (QUOTE DSP))) (* Buffer can get this turned on)
W])
(FINDEDITW
[LAMBDA (NAME TYPE) (* bas: "18-MAR-83 15:25")
(for I in \DEDITWINDOWS thereis (SAMEEDITW I NAME TYPE])
(GETEDITW
[LAMBDA (ATM TYPE) (* bas: "18-MAR-83 15:25")
(SELECTQ TYPE
(NIL (OR ATM (SETQ ATM (CONCAT " "))) (* A unique, but invisible tag)
(SETQQ TYPE expression))
(PROP (SETQQ TYPE FNS))
NIL)
(PROG [(W (OR (FINDEDITW ATM TYPE)
(MAKEEDITW ATM TYPE]
(RESETSAVE \DEDITWINDOWS (CONS W \DEDITWINDOWS))
(RESETSAVE NIL (LIST (QUOTE UNDEDITW)
\DEDITWINDOWS))
(RETURN (WINDOWPROP W (QUOTE DSP])
(MAKEEDITW
[LAMBDA (NAME TYP) (* bas: "18-MAR-83 14:26")
(ACTIVEEDITW (PROG [(W (if (TOPEDITW)
then (WINDOWPROP (TOPEDITW)
(QUOTE DEDITCACHED))
else (WINDOWP DEditWindow]
(DECLARE (USEDFREE EDITCHANGES))
(AND (if (NOT W)
then (SETQ W (CREATEW NIL (NAMEOFEDITW NAME TYP)))
elseif (NOT (SAMEEDITW W NAME TYP))
then (WINDOWPROP W (QUOTE TITLE)
(NAMEOFEDITW NAME TYP))
T)
(WINDOWPROP W (QUOTE DEDITWHOAMI)
(LIST NAME TYP)))
(WINDOWPROP W (QUOTE DEDITCHANGES)
EDITCHANGES) (* Associates changes with changed structure)
(RETURN W))
T])
(NAMEOFEDITW
[LAMBDA (NAME TYPE) (* bas: "30-MAR-83 18:41")
(CONCAT "DEdit of " (SELECTQ TYPE
(FNS "function")
(PROPS (if (CADR (LISTP NAME))
then (PROG1 (CONCAT (CADR NAME)
" property of ")
(SETQ NAME (CAR NAME)))
else "property list of"))
(VARS (if (AND (STREQUAL (SUBSTRING NAME -4 -1)
"COMS")
(HASDEF (SUBSTRING NAME 1 -5)
(QUOTE FILE)))
then (PROG1 "filecoms for file" (SETQ NAME
(SUBSTRING NAME 1 -5)))
else "variable"))
TYPE)
" " NAME])
(PURGEW
[LAMBDA (W DONTCLR) (* bas: "21-MAR-83 19:48")
(PROG [(WDS (if (WINDOWP W)
then (WINDOWPROP W (QUOTE DSP))
else (PROG1 W (SETQ W (WFROMDS W]
[if (EQ W DEditWindow)
then (CLRHASH \DEDITMEHASH)
(CLRHASH \DEDITDPHASH)
else (MAPHASH \DEDITMEHASH (FUNCTION (LAMBDA (X Y)
(AND (EQ WDS (fetch PDSP of X))
(PUTHASH Y NIL \DEDITMEHASH]
(WINDOWPROP W (QUOTE EDITEXPR)
NIL)
(if DONTCLR
else (DSPTEXTURE WHITESHADE W)
(DSPFONT (CADR DEFAULTFONT)
W) (* Font first to get CLEARW right)
(CLEARW W)
(MAKECPOSBE NIL 62000 W)))
W])
(MAKECPOSBE
[LAMBDA (X Y DS) (* bas: "17-MAR-83 18:48")
(PROG ((DX (if (FIXP X)
then (IDIFFERENCE X (DSPXPOSITION NIL DS))
else 0))
(DY (if (FIXP Y)
then (IDIFFERENCE Y (DSPYPOSITION NIL DS))
else 0)))
(WXOFFSET (IMINUS DX)
DS)
(WYOFFSET (IMINUS DY)
DS)
(RELMOVETO DX DY DS])
(SAMEEDITW
[LAMBDA (W NAME TYPE) (* bas: "15-FEB-82 18:16")
(PROG [(TMP (WINDOWPROP W (QUOTE DEDITWHOAMI]
(RETURN (AND TMP (EQ NAME (CAR TMP))
(EQ TYPE (CADR TMP])
(TOPEDITW
[LAMBDA NIL (* bas: "18-MAR-83 15:25")
(CAR \DEDITWINDOWS])
(UNDEDITW
[LAMBDA (WDS) (* bas: "21-MAR-83 19:54")
(* Desensitizes DEDIT windows and removes surplus ones)
(AND \DEDITMNUW (CLOSEW \DEDITMNUW))
(PROG [(W (WFROMDS (OR (CAR (LISTP WDS))
(SHOULDNT]
(AND \DEDITBUFW (EQ \DEDITBUFW (WINDOWPROP W (QUOTE EDITBUF)))
(PROGN (TAKEDOWN \DEDITBUFW)
(SETQ \DEDITBUFW NIL)))
(DECLARE (USEDFREE DEditLinger))
(if (EQ WDS \DEDITWINDOWS)
then (SETQ \DEDITWINDOWS (CDR WDS))
else (for I on WDS when (EQ WDS (CDR I)) do (RETURN (RPLACD I (CDDR I)))
finally (SHOULDNT "DEDITDSPS tangled")))
(if (CDR WDS)
then (if (FMEMB W (CDR WDS))
else (WINDOWPROP W (QUOTE DEDITCACHED)
NIL) (* Discard my cache; cache me on next)
(WINDOWPROP (CADR WDS)
(QUOTE DEDITCACHED)
W)
(TAKEDOWN W))
else (AND RESETSTATE (CADR (WINDOWPROP W (QUOTE DEDITCHANGES)
NIL))
(ZORCHEDITW W))
(OR (WINDOWP DEditWindow)
(SETQ DEditWindow W))
(OR DEditLinger (CLOSEW W])
(WHICHEDITW
[LAMBDA (CC) (* bas: " 4-FEB-83 15:45")
(bind SCR for TMP from (GETME4 CC) by (fetch BP of TMP) while TMP
do (AND (SETQ SCR (EDITWINDOWP (fetch PDSP of TMP)))
(RETURN SCR])
(ZORCHEDITW
[LAMBDA (W) (* bas: " 5-FEB-83 19:03")
(AND W (PURGEMAP (GETMAP? W))
(ACTIVEWP (WFROMDS W))
(PROGN (DSPTEXTURE CHANGEDSHADE W)
(DSPFILL NIL CHANGEDSHADE (QUOTE PAINT)
W])
)
(DEFINEQ
(BUFSELP
[LAMBDA (E) (* bas: "21-MAR-83 19:53")
(AND E \DEDITBUFW (EQ (fetch PDSP of E)
(WINDOWPROP \DEDITBUFW (QUOTE DSP])
(EDITWINDOWP
[LAMBDA (W) (* bas: "14-MAY-82 15:51")
(AND (OR (WINDOWP W)
(type? DISPLAYSTREAM W))
(WINDOWPROP W (QUOTE EDITEXPR))
(WINDOWPROP W (QUOTE DSP])
(GETLEFT
[LAMBDA (SEL BK) (* bas: "16-MAR-83 09:45")
(AND (OR BK (SETQ BK (fetch BP of SEL)))
(for I on (fetch SELEXP of BK) when (if (LISTP (CDR I))
then (EQ (CDR I)
(fetch TAIL of SEL))
elseif (CDR I)
then (EQ (CDR I)
(fetch SELEXP of SEL))
else NIL)
do (RETURN (GETME4 I])
(GETMEBP
[LAMBDA (E) (* bas: "13-OCT-81 16:21")
(OR (fetch BP of E)
(CANT "At top"])
(INTAILOF
[LAMBDA (M F) (* bas: "21-MAR-83 19:58")
(if (type? DEDITMAP M)
then (AND (EQ F (fetch BP of M))
(INTAILOF (fetch TAIL of M)
F))
elseif (LISTP M)
then [OR (TAILP M (fetch SELEXP of F))
(AND (CDR (LISTP M))
(NLISTP (CDR M))
(EQ M (GETHASH (fetch TAIL of F)
\DEDITDPHASH]
elseif M
then (EQ M (DOTTEDEND (fetch SELEXP of F])
(TAILOF
[LAMBDA (A B) (* bas: "16-MAR-83 12:22")
(OR (TAILP A B)
(AND (SETQ A (DPCDRSEL A))
(TAILP B (fetch SELEXP of (fetch BP of A])
(DOTTEDEND
[LAMBDA (C) (* bas: "16-MAR-83 21:32")
(if (LISTP C)
then (CDR (LAST C))
else C])
(GETME4
[LAMBDA (C B) (* bas: "30-MAR-83 16:19")
(AND C
(OR (GETHASH C \DEDITMEHASH)
(SELECTQ B
(NIL NIL)
(T (SHOULDNT "No MapEntry"))
(PROGN (OR [INTAILOF C (OR (MAPENTRYP B)
(SETQ B (GETME4 B T]
(SHOULDNT "Invalid BP"))
(if (NLISTP C)
then (GETDPME B)
elseif [MAPENTRYP (MAPHASH \DEDITMEHASH
(FUNCTION (LAMBDA (X Y)
(AND (EQ B (fetch BP of X))
(EQUAL C Y)
(PROGN (PUTHASH Y NIL \DEDITMEHASH)
(replace TAIL of X
with C)
(PUTHASH C X \DEDITMEHASH)
(RETFROM (QUOTE MAPHASH)
X]
else (DEARME B])
(GETSELMAP
[LAMBDA (X) (* bas: "13-MAR-83 19:59")
(* Gets ME iff it is unpurged ie visible for a
SHADESELECTIOn etc)
(AND X (SETQ X (GETME4 X))
(NOT (fetch PURGED of X))
X])
(DEARME
[LAMBDA (B) (* bas: " 7-MAR-83 22:49")
(REPP B)
(for (SP ←(REALSTKNTH -1 (QUOTE GETME4))) by (STKPOS (STKNAME SP)
-1
(STKNTH -1 SP SP)
SP)
while SP when (EQ B (STKARG 1 SP)) do (RETEVAL SP [CONS (STKNAME SP)
(CONS (GETME4 (fetch TAIL
of B)
T)
(CDR (STKARGS SP]
T)
finally (RETURN (GETME4 (fetch TAIL of B)
T])
(DPCDRSEL
[LAMBDA (ME) (* bas: "21-MAR-83 19:58")
(AND [OR (type? DEDITMAP ME)
(AND (CDR (LISTP ME))
(NLISTP (CDR ME))
(SETQ ME (GETME4 ME]
(fetch BP of ME)
(EQ ME (GETDPME (fetch BP of ME)))
ME])
(GETDPME
[LAMBDA (B) (* bas: "21-MAR-83 19:48")
(GETME4 (GETHASH (fetch TAIL of B)
\DEDITDPHASH)
T])
(GETEBUF
[LAMBDA (ACTP) (* bas: "21-MAR-83 19:53")
(PROG ((REG (WINDOWPROP (TOPEDITW)
(QUOTE REGION)))
(EBW (WINDOWPROP (TOPEDITW)
(QUOTE EDITBUF)))
TR X Y W H)
(SETQ X (fetch LEFT of REG))
(SETQ W (fetch WIDTH of REG))
(SETQ H 72)
(AND \DEDITBUFW (NEQ EBW \DEDITBUFW)
(CLOSEW \DEDITBUFW))
(if (NOT EBW)
then (SETQ \DEDITBUFW (CREATEW (create REGION
LEFT ← X
BOTTOM ←(IDIFFERENCE (fetch BOTTOM of REG)
H)
WIDTH ← W
HEIGHT ← H)
"Edit buffer"))
(WINDOWPROP (TOPEDITW)
(QUOTE EDITBUF)
\DEDITBUFW)
elseif (PROGN (PURGEW (SETQ \DEDITBUFW EBW))
(SETQ TR (WINDOWPROP \DEDITBUFW (QUOTE REGION)))
[SETQ Y (IDIFFERENCE (fetch BOTTOM of REG)
(SETQ H (fetch HEIGHT of TR]
(NEQ W (fetch WIDTH of TR)))
then (* No DEdit specific reshaping will happen b/c window
has been purged)
(SHAPEW \DEDITBUFW
(create REGION
LEFT ← X
BOTTOM ← Y
WIDTH ← W
HEIGHT ← H))
elseif (NEQ X (fetch LEFT of TR))
then (MOVEW \DEDITBUFW (create POSITION
XCOORD ← X
YCOORD ← Y))
(OPENW \DEDITBUFW)
else (OPENW \DEDITBUFW))
(RETURN (WINDOWPROP (ACTIVEEDITW \DEDITBUFW ACTP)
(QUOTE DSP])
(GETEDITCHAIN
[LAMBDA (E) (* bas: "30-MAR-83 21:45")
(DECLARE (USEDFREE LASTAIL))
(if (LISTP E)
then (SETQ LASTAIL E)
(SETQ E (OR (GETME4 E)
E))
elseif (type? DEDITMAP E)
then (SETQ LASTAIL (fetch TAIL of E))
elseif E
then (SHOULDNT))
(OR (LISTP E)
(for (I ← E) by (fetch BP of I) while I collect (fetch SELEXP of I])
(GETMAP
[LAMBDA (DS) (* bas: "14-MAY-82 16:02")
(OR (GETMAP? DS)
(SETDEDITMAP DS (WINDOWPROP DS (QUOTE EDITEXPR])
(GETMAP?
[LAMBDA (W) (* bas: " 9-MAR-83 16:39")
(PROG [(WM (GETME4 (WINDOWPROP W (QUOTE EDITEXPR]
(AND WM (NOT (PURGEDP WM))
(RETURN WM])
(PURGEMAP
[LAMBDA (M) (* bas: "11-MAR-83 14:52")
(if M
then (replace PURGED of M with (QUOTE PURGED)) (* Mark as dead))
M])
(PURGEDP
[LAMBDA (M) (* bas: "30-MAR-83 16:19")
(* This is unfortunately an expensive operation as some edit operations can cut a cons out of the structure being
edited without that being obvious at the time it happens. The only way therefore to be sure that a ME really is
valid is to chase its BPs all the way out to the top.)
(OR (fetch PURGED of M)
(AND [OR (NEQ M (GETME4 (fetch TAIL of M)))
(AND (fetch BP of M)
(OR (NOT (INTAILOF M (fetch BP of M)))
(PURGEDP (fetch BP of M]
(PURGEMAP M])
(SUBSELOF
[LAMBDA (TOP SUB) (* bas: " 7-AUG-83 16:46")
(for (S2 ←(GETME4 SUB)) by (fetch BP of S2) while S2 until (fetch PURGED of S2)
thereis (EQ TOP (fetch SELEXP of S2])
(SETDEDITMAP
[LAMBDA (DW V) (* bas: "24-MAR-83 14:31")
(PURGEW DW) (* Remove EDITEXPR and reset window)
[SETQ V (DEPRINTDEF (OR (LISTP V)
(LIST V))
(DSPLEFTMARGIN NIL DW)
(QUOTE DEFAULTFONT)
(WINDOWPROP DW (QUOTE DSP]
(WINDOWPROP DW (QUOTE EDITEXPR)
(fetch TAIL of V))
[WINDOWPROP DW (QUOTE EXTENT)
(create REGION
LEFT ← 0
BOTTOM ←(LOWPT V)
WIDTH ←(WINDOWPROP DW (QUOTE WIDTH))
HEIGHT ←(ADD1 (IDIFFERENCE (HIPT V)
(LOWPT V]
V])
(TAKEDOWN
[LAMBDA (WDS) (* bas: "11-NOV-82 19:38")
(PURGEW WDS T)
(CLOSEW WDS])
)
(DEFINEQ
(DEDITRESHAPEFN
[LAMBDA (W X1 X2) (* bas: "24-MAR-83 15:34")
(AND (EDITWINDOWP W)
(RESETFORM (CURSOR WAITINGCURSOR)
(SETDEDITMAP W (WINDOWPROP W (QUOTE EDITEXPR)))
(AND (EQ W (TOPEDITW))
(SETEDITMENU W))
(FLIPSELSIN W])
(DEDITSCROLLFN
[LAMBDA (W DX DY CFLG) (* bas: "24-MAR-83 15:37")
(FLIPSELSIN W)
(SCROLLBYREPAINTFN W DX DY CFLG)
(FLIPSELSIN W])
(DEDITREPAINTFN
[LAMBDA (WDS R) (* bas: " 5-FEB-83 18:16")
(REFRESHIF WDS (fetch PTOP of R)
(fetch BOTTOM of R])
)
(DEFINEQ
(SETEDITMENU
[LAMBDA (EW) (* bas: "24-MAR-83 13:58")
(DECLARE (GLOBALVARS \DEDITCOMS))
(PROG ((ER (WINDOWPROP EW (QUOTE REGION)))
[MR (AND (WINDOWP \DEDITMNUW)
(WINDOWPROP \DEDITMNUW (QUOTE REGION]
X Y H W IMAGE)
(* The WINDOWP check on \DEDITMNUW is b/c it can be a displaystream if user interrupts out of READEDITMENU in
which case it must be rebuilt b/c of possible undone inversions)
(if MR
then (SETQ W (fetch WIDTH of MR))
(SETQ H (fetch HEIGHT of MR))
else (SETQ IMAGE (CACHEDEDITCOMS \DEDITCOMS))
(SETQ W (ITIMES 2 (SUB1 WBorder)))
(SETQ H (IPLUS (fetch BITMAPHEIGHT of IMAGE)
(IMINUS (DSPLINEFEED NIL WindowTitleDisplayStream))
W))
(SETQ W (IPLUS (fetch BITMAPWIDTH of IMAGE)
W)))
(SETQ X (IMIN (fetch RIGHT of ER)
(IDIFFERENCE SCREENWIDTH W)))
(SETQ Y (IMAX (IDIFFERENCE (IMIN SCREENHEIGHT (fetch PTOP of ER))
H)
0))
(if MR
then (if (OR (NEQ X (fetch LEFT of MR))
(NEQ Y (fetch BOTTOM of MR)))
then (PROG ((P (create POSITION
XCOORD ← X
YCOORD ← Y)))
(MOVEW \DEDITMNUW P)
(WINDOWPROP \DEDITMNUW (QUOTE HOME)
P)))
(OPENW \DEDITMNUW)
else [PROG ((NUR (create REGION
LEFT ← X
BOTTOM ← Y
WIDTH ← W
HEIGHT ← H)))
(SETQ \DEDITMNUW (if (DISPLAYSTREAMP \DEDITMNUW)
then (PROG1 (WFROMDS \DEDITMNUW)
(SHAPEW \DEDITMNUW NUR))
else (CREATEW NUR (QUOTE EditOps]
(BITBLT IMAGE 1 1 \DEDITMNUW 0 0 W H (QUOTE INPUT)
(QUOTE REPLACE)) (* The 1,1 removes the menu border)
(WINDOWPROP \DEDITMNUW (QUOTE ITEMHEIGHT)
(FONTPROP MENUFONT (QUOTE HEIGHT)))
(WINDOWPROP \DEDITMNUW (QUOTE YOFFSET)
(IQUOTIENT H 2))
(WINDOWPROP \DEDITMNUW (QUOTE HOME)
(create POSITION
XCOORD ← X
YCOORD ← Y))
(WINDOWPROP \DEDITMNUW (QUOTE REPAINTFN)
(QUOTE DEDITMENURESTORE)))
(RETURN \DEDITMNUW])
(CACHEDEDITCOMS
[LAMBDA (CL) (* bas: "21-MAR-83 19:57")
(* Caches info from \DEDITCOMS into arrays in INVERSE
order for convenience of READEDITMENU)
(DECLARE (GLOBALVARS EDITMENU\COMS EDITMENU\SUBS))
(SETQ EDITMENU\COMS (ARRAY (LENGTH CL)
NIL NIL 0))
(SETQ EDITMENU\SUBS (ARRAY (ARRAYSIZE EDITMENU\COMS)
NIL NIL 0))
[for I in CL as J from (SUB1 (ARRAYSIZE EDITMENU\COMS)) by -1
do (SETA EDITMENU\COMS J (CONS (CAR I)
(CADR I)))
(SETA EDITMENU\SUBS J (AND (CDDR I)
(create MENU
ITEMS ←[for Q in (CDDR I)
collect (LIST (CAR Q)
(LIST (QUOTE QUOTE)
(CONS (CAR Q)
(CADR Q]
CENTERFLG ← T
MENUOFFSET ←(create POSITION
XCOORD ← -1
YCOORD ←(IQUOTIENT
(ITIMES (FONTPROP MENUFONT
(QUOTE HEIGHT))
(LENGTH (CDDR I)))
2]
(CHECK/MENU/IMAGE (create MENU
ITEMS ← CL
CENTERFLG ← T])
(DEFDEDITCOM
[LAMBDA (COM FORM SUP BEFORE) (* bas: "21-MAR-83 19:57")
(DECLARE (GLOBALVARS \DEDITCOMS))
(SETQ \DEDITCOMS (CONS NIL \DEDITCOMS)) (* Finesse empty list case)
(PROG1 (PROG (CDEF AC SC)
[AND SUP (SETQ SC (CDADR (OR (LISTP (FINDEDITCOM SUP \DEDITCOMS))
(RETURN]
(if (SETQ AC (FINDEDITCOM COM (OR SC \DEDITCOMS)))
then (* Delete old entry)
(/RPLACD AC (CDDR AC)))
(SETQ CDEF (LIST COM (SELECTQ FORM
(NIL (RETURN))
(T (PACK* (QUOTE DEDIT)
COM))
FORM)))
(AND BEFORE (SETQ AC (FINDEDITCOM BEFORE (OR SC \DEDITCOMS)
T)))
(if AC
then (/RPLACD AC (CONS CDEF (CDR AC)))
else (/NCONC (OR SC \DEDITCOMS)
(LIST CDEF)))
(RETURN CDEF))
(SETQ \DEDITCOMS (CDR \DEDITCOMS))
(SETQ \DEDITMNUW NIL])
(FINDEDITCOM
[LAMBDA (C L EFLG) (* bas: "19-NOV-82 15:28")
(for I on L thereis (OR (EQUAL C (CAR (CADR I)))
(AND EFLG (NOT (CDR I])
(READEDITMENU
[LAMBDA NIL (* bas: "21-MAR-83 19:54")
(DECLARE (GLOBALVARS EDITMENU\COMS EDITMENU\SUBS))
(bind OTHERS N OLDN ISDOWN EMDS (VLF ←(WINDOWPROP \DEDITMNUW (QUOTE ITEMHEIGHT)))
first (PROGN [SETQ \DEDITMNUW (SETQ EMDS (WINDOWPROP \DEDITMNUW (QUOTE DSP]
(* Clear menu to protect against ↑E)
)
eachtime (GETMOUSESTATE) while [AND (EQ \DEDITMNUW EMDS)
(NOT (READP T))
[OR (INWINDOW EMDS)
(AND OTHERS (KEYDOWNP (QUOTE CTRL]
(OR (NOT N)
(if (KEYDOWNP (QUOTE CTRL))
then (PROG1 (push OTHERS (CONS OLDN N))
(SETQ N NIL]
when (INWINDOW EMDS)
do (SETQ N (IQUOTIENT (LASTMOUSEY EMDS)
VLF)) (* Index from bottom)
(if (EQ N OLDN)
then (\BACKGROUND) (* Nothing going on)
else [OR (FASSOC OLDN OTHERS)
(SHADEMENUENTRY OLDN EMDS VLF (if (EQ ISDOWN OLDN)
then (QUOTE FILL)
else (QUOTE BOX]
(OR (FASSOC N OTHERS)
(SHADEMENUENTRY N EMDS VLF (QUOTE BOX)))
(SETQ OLDN N))
(SETQ N (if (LASTMOUSESTATE (NOT UP))
then (OR (EQ ISDOWN N)
(SHADEMENUENTRY N EMDS VLF (QUOTE HOLLOW)))
(SETQ ISDOWN N)
[AND (LASTMOUSESTATE (NOT RED))
(ELT EDITMENU\SUBS N)
(OR (MENU (ELT EDITMENU\SUBS N))
(PROG1 (SETQ ISDOWN NIL)
(SHADEMENUENTRY N EMDS VLF (QUOTE HOLLOW]
elseif ISDOWN
then (SETQ ISDOWN NIL)
(ELT EDITMENU\COMS N)))
finally [OR (FASSOC OLDN OTHERS)
(SHADEMENUENTRY OLDN EMDS VLF (if (OR N ISDOWN)
then (QUOTE FILL)
else (QUOTE BOX]
(for I in OTHERS do (SHADEMENUENTRY (CAR I)
EMDS VLF (QUOTE FILL)))
[AND N OLDN (WINDOWPROP EMDS (QUOTE YOFFSET)
(ITIMES VLF (ADD1 OLDN]
(SETQ \DEDITMNUW (if \DEDITMNUW
then (WFROMDS EMDS)
else EMDS)) (* Exited cleanly, restore global)
(RETURN (if OTHERS
then [AND N (bind CS XS for I in (CONS (CONS OLDN N)
OTHERS)
do (push CS (CADR I))
[push XS (OR (LISTP (CDDR I))
(LIST (CDDR I]
finally (RETURN (CONS CS (CONS (QUOTE PROGN)
XS]
else N])
(SHADEMENUENTRY
[LAMBDA (V EMDS DLF BOXFLG) (* bas: "28-OCT-82 18:28")
(AND V (SELECTQ BOXFLG
(FILL (BITBLT NIL NIL NIL EMDS 0 (ITIMES V DLF)
1000 DLF (QUOTE TEXTURE)
(QUOTE INVERT)
BLACKSHADE))
(HOLLOW (BITBLT NIL NIL NIL EMDS 1 (ADD1 (ITIMES V DLF))
(IDIFFERENCE (fetch WIDTH of (DSPCLIPPINGREGION NIL EMDS))
2)
(IDIFFERENCE DLF 2)
(QUOTE TEXTURE)
(QUOTE INVERT)
BLACKSHADE))
(BOX (* FILL then HOLLOW)
(BITBLT NIL NIL NIL EMDS 0 (ITIMES V DLF)
1000 DLF (QUOTE TEXTURE)
(QUOTE INVERT)
BLACKSHADE)
(BITBLT NIL NIL NIL EMDS 1 (ADD1 (ITIMES V DLF))
(IDIFFERENCE (fetch WIDTH of (DSPCLIPPINGREGION NIL EMDS))
2)
(IDIFFERENCE DLF 2)
(QUOTE TEXTURE)
(QUOTE INVERT)
BLACKSHADE))
(SHOULDNT])
(DEDITMENURESTORE
[LAMBDA (W R) (* bas: "24-MAR-83 14:04")
(* If \DEDITMNUW is a display stream it is considered to have flaky contents and will be regenerated.
If we are under a READEDITMENU, \DEDITMNUW is ALREADY a display steam, so we set it to NIL to signal READEDITMENU
not to restore it.)
(SETQ \DEDITMNUW (if (EQ \DEDITMNUW W)
then (WINDOWPROP W (QUOTE DSP))
else NIL])
)
(DEFINEQ
(RESETDEDIT
[LAMBDA NIL (* bas: "30-MAR-83 20:57")
(DECLARE (GLOBALVARS \DEDITCOMS))
[PROGN (MOVD? (QUOTE MARKASCHANGED)
(QUOTE NORMAL/MARKASCHANGED))
(MOVD (QUOTE DEDITMARKASCHANGED)
(QUOTE MARKASCHANGED))
(MOVD? (QUOTE EDITDATE)
(QUOTE NORMAL\EDITDATE))
(MOVD (QUOTE DEDITDATE)
(QUOTE EDITDATE))
(MOVD? (QUOTE EDITL)
(QUOTE NORMAL/EDITL))
(EDITMODE (if (BOUNDP (QUOTE DEditMode))
then DEditMode
else (QUOTE DISPLAY]
(PROGN (for I in (CONS DEditWindow (LISTP \DEDITWINDOWS)) when (WINDOWP I) do (CLOSEW I))
(SETQ DEditWindow NIL) (* Initialize DEDIT globals)
(SETQ \DEDITWINDOWS NIL)
(SETQ \DEDITALLOWSELS NIL)
(SETQ \DEDITSELECTIONS NIL)
(SETQ \DEDITBUFW NIL)
(SETQ \DEDITMNUW NIL)
(SETQ \DEDITMEHASH (CONS (HARRAY 255)))
(SETQ \DEDITDPHASH (CONS (HARRAY 255)))
(SETQ \DEDITCOMS NIL)
(DEDITResetTypeComs)) (* Rest of code sets initial DEDIT commands)
(for I in (QUOTE (After Before Delete Replace Switch Undo Find Swap Reprint Edit EditCom Break
Eval Exit))
do (DEFDEDITCOM I T))
(PROGN (DEFDEDITCOM "( )" (QUOTE DEDITBI)
NIL
(QUOTE Undo))
(for I in (QUOTE (("( ) in" DEDITBI)
("( in" DEDITLI)
(") in" DEDITRI)))
do (DEFDEDITCOM (CAR I)
(CADR I)
"( )")))
(PROGN (DEFDEDITCOM "( ) out" (QUOTE DEDITBO)
NIL
(QUOTE Undo))
(for I in (QUOTE (("( ) out" DEDITBO)
("( out" DEDITLO)
(") out" DEDITRO)))
do (DEFDEDITCOM (CAR I)
(CADR I)
"( ) out")))
(PROGN (DEFDEDITCOM (QUOTE Undo)
T
(QUOTE Undo))
(DEFDEDITCOM (QUOTE !Undo)
(QUOTE (DEDITUndo T))
(QUOTE Undo))
(DEFDEDITCOM (QUOTE ?Undo)
(QUOTE (UNDOCHOOSE))
(QUOTE Undo))
(DEFDEDITCOM (QUOTE &Undo)
(QUOTE (UNDOCHOOSE T))
(QUOTE Undo)))
(PROGN (DEFDEDITCOM (QUOTE Center)
T
(QUOTE Swap))
(DEFDEDITCOM (QUOTE Clear)
(QUOTE (SETQ \DEDITSELECTIONS NIL))
(QUOTE Swap))
(DEFDEDITCOM (QUOTE Copy)
T
(QUOTE Swap))
(DEFDEDITCOM (QUOTE Pop)
(QUOTE (POPSELECTION))
(QUOTE Swap))
(DEFDEDITCOM (QUOTE Swap)
T
(QUOTE Swap)))
[for I in (QUOTE (DEdit TTYEdit TTYIn))
do (for J in (QUOTE (Def Form)) do (DEFDEDITCOM (PACK* I " " J)
(LIST (QUOTE DEDITEdit)
(SELECTQ I
(DEdit (QUOTE (QUOTE DISPLAY)))
(TTYEdit (QUOTE (QUOTE TELETYPE)
))
(KWOTE I))
(KWOTE J))
(QUOTE Edit]
[PROGN (DEFDEDITCOM (QUOTE ?=)
(QUOTE DEDITARGS)
(QUOTE EditCom))
(for I in (QUOTE (GETD CL DW REPACK CAP LOWER RAISE)) do (DEFDEDITCOM I
(LIST (QUOTE
DEDITEditCom)
(KWOTE I))
(QUOTE EditCom]
(PROGN (DEFDEDITCOM (QUOTE OK)
(QUOTE DEDITExit)
(QUOTE Exit))
(DEFDEDITCOM (QUOTE STOP)
(QUOTE (DEDITExit T))
(QUOTE Exit)))
T])
(DEDITDATE
[LAMBDA (OLDATE INITLS) (* bas: " 5-FEB-83 19:36")
(PROG1 (NORMAL\EDITDATE OLDATE INITLS)
(PROG (ODM W)
(AND (SETQ ODM (GETME4 (LISTP OLDATE)))
(SETQ ODM (fetch BP of ODM))
[ACTIVEWP (SETQ W (WFROMDS (fetch PDSP of ODM]
(GETMAP? W)
(REPP ODM])
(DEDITMARKASCHANGED
[LAMBDA (NAME TYPE REASON) (* bas: "18-MAR-83 15:25")
(PROG1 (NORMAL/MARKASCHANGED NAME TYPE REASON)
(* MARKASCHANGED is called after DEDITL exits. Hence a scan of the \DEDITWINDOWS chain finds all active DEDITs
excluding the one just exited. The separate test on DEditWindow discriminates between exit from topmost DEDIT and
other changes to the top level window)
(ZORCHEDITW (if (FINDEDITW NAME TYPE)
else (AND (WINDOWP DEditWindow)
(SAMEEDITW DEditWindow NAME TYPE)
(NOT (CADR (WINDOWPROP DEditWindow (QUOTE DEDITCHANGES)
NIL)))
DEditWindow])
)
(DEFINEQ
(DEDITResetTypeComs
[LAMBDA NIL (* bas: "31-MAR-83 08:51")
(SETQ DEditTypedCom "TypedCom")
(SETQ DEDITTTBL (COPYTERMTABLE NIL))
(SETQ DEDITRDTBL (COPYREADTABLE T))
(bind C for I in DEDITTYPEINCOMS
do (SETQ C (IPLUS (IDIFFERENCE (CHCON1 (CAR I))
(CHARCODE A))
(CHARCODE ↑A)))
(ECHOCONTROL C (QUOTE IGNORE)
DEDITTTBL)
(SETSYNTAX C [SUBST (KWOTE (CADR I))
(QUOTE Y)
(QUOTE (MACRO FIRST IMMEDIATE (LAMBDA (F R)
(BKSYSBUF Y)
(BKSYSBUF " ")
DEditTypedCom]
DEDITRDTBL])
(DEDITTYPEDCOM
[LAMBDA (TC) (* bas: "31-MAR-83 08:51")
(for J in DEDITTYPEINCOMS when (EQ (CADR J)
(CAR TC))
do (RETURN (CONS (CADR J)
(CONS (CADDR J)
(CDR TC])
)
(DEFINEQ
(COPYCONS
[LAMBDA (C) (* bas: "22-FEB-82 14:20")
(CONS (CAR C)
(CDR C])
(MAPENTRYP
[LAMBDA (V) (* bas: "21-MAR-83 19:58")
(AND (type? DEDITMAP V)
V])
(THELIST
[LAMBDA (X) (* bas: "21-JUL-82 18:11")
(OR (LISTP X)
(CANT "Not a list!"])
)
(DEFINEQ
(CANT
[LAMBDA NMSGS (* bas: " 9-AUG-82 12:14")
(* Report error by flashing window)
(DSPRESET PROMPTWINDOW)
(printout PROMPTWINDOW T "Cant:")
(for I to NMSGS do (printout PROMPTWINDOW , (ARG NMSGS I)))
(DSPFILL NIL BLACKSHADE (QUOTE INVERT)
PROMPTWINDOW)
(DISMISS 100)
(DSPFILL NIL BLACKSHADE (QUOTE INVERT)
PROMPTWINDOW)
(ERROR!])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD STACK (TOPELT NXTELT)
(CREATE NIL))
]
(DECLARE: EVAL@COMPILE
(PUTPROPS EDITBLOCKCALL MACRO (F (CONS (PACK* (QUOTE \EDITBLOCK/)
(CAR F))
(CDR F))))
)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS DEditWindow \DEDITMNUW \DEDITBUFW \DEDITALLOWSELS \DEDITWINDOWS \DEDITSELECTIONS)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \DEDITTYPECOMS DEditTypedCom DEDITTTBL DEDITRDTBL)
)
(ADDTOVAR DEDITTYPEINCOMS (F Find [NLAMBDA (TGT)
(PUSHSELECTION (LIST TGT))
(DEDITSwap)
(DEDITFind])
[S Substitute (NLAMBDA (OLD NEW)
(DEDITEditCom (LIST (QUOTE R)
OLD NEW]
(Z EditCom [NLAMBDA (EC)
(DEDITEditCom EC]))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS ATM EDITCHANGES EDITHIST LASTAIL UNDOLST UNDOLST1)
)
(RPAQ? DEditLinger T)
(DECLARE: EVAL@COMPILE
(RPAQQ LINETHICKNESS 2)
(RPAQQ PRIMSHADE 65535)
(RPAQQ SECSHADE 3598)
(RPAQ SWITCHSHADE (LOGXOR PRIMSHADE SECSHADE))
(RPAQQ READSHADE 23130)
(RPAQQ CHANGEDSHADE 8840)
(CONSTANTS (LINETHICKNESS 2)
(PRIMSHADE 65535)
(SECSHADE 3598)
(SWITCHSHADE (LOGXOR PRIMSHADE SECSHADE))
(READSHADE 23130)
(CHANGEDSHADE 8840))
)
(FILESLOAD DSPRINTDEF NEWPRINTDEF)
(AND (GETD (QUOTE RESETDEDIT))
(RESETDEDIT))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA EP EV EF DC DP DV DF)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA CANT)
)
(PUTPROPS DEDIT COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2654 5148 (DF 2664 . 2826) (DV 2828 . 2991) (DP 2993 . 3169) (DC 3171 . 3601) (EF 3603
. 3766) (EV 3768 . 3932) (EP 3934 . 4111) (EDITPROP 4113 . 4341) (EDITMODE 4343 . 4977) (DEDITIT 4979
. 5146)) (5149 11816 (DEDITL 5159 . 8127) (DEDITL0 8129 . 10432) (DEDITTTYFN 10434 . 11814)) (11817
23415 (DEDITAfter 11827 . 12215) (DEDITBefore 12217 . 12574) (DEDITDelete 12576 . 13146) (DEDITReplace
13148 . 13436) (DEDITSwitch 13438 . 13801) (DEDITBI 13803 . 14377) (DEDITBO 14379 . 14624) (DEDITLI
14626 . 14813) (DEDITLO 14815 . 15006) (DEDITRI 15008 . 15362) (DEDITRO 15364 . 15575) (DEDITUndo
15577 . 16108) (UNDOCHOOSE 16110 . 16852) (DEDITFind 16854 . 17367) (DEDITSwap 17369 . 17654) (
DEDITCenter 17656 . 18467) (DEDITCopy 18469 . 18633) (DEDITReprint 18635 . 18793) (DEDITCEdit 18795 .
19241) (DEDITEdit 19243 . 20329) (DEDITEditCom 20331 . 21126) (DEDITARGS 21128 . 21459) (DEDITBreak
21461 . 22752) (DEDITEval 22754 . 23054) (DEDITExit 23056 . 23413)) (23416 32041 (SETPTRTO 23426 .
24014) (DEDITCONS 24016 . 24264) (DEDITZAPCAR 24266 . 24456) (DEDITZAPCDR 24458 . 24653) (DEDITZAPNODE
24655 . 24809) (DEDITZAPBOTH 24811 . 27080) (DEDITFZAP 27082 . 27762) (DEDITZAPCLISP 27764 . 28594) (
DEDITZAPCHANGES 28596 . 29325) (DEDITNCONC 29327 . 29491) (DUNDOEDITL 29493 . 30363) (DUNDOEDITCOM
30365 . 31339) (DUNDOEDITCOM1 31341 . 32039)) (32042 40639 (BSELECT 32052 . 33109) (DEDITUSER 33111 .
33522) (SELECTKEYS 33524 . 34593) (SHADEIFNOTBUF 34595 . 34797) (DEDITBUTTONFN 34799 . 35209) (
DEDITRIGHTBUTTONFN 35211 . 35468) (SELECTELEMENT 35470 . 36169) (SELECTREAD 36171 . 37003) (SELECTTREE
37005 . 37390) (SEARCHMAP 37392 . 38328) (WITHINME 38330 . 39148) (ONAPARENP 39150 . 39596) (
SELECTDONE 39598 . 39755) (INWINDOW 39757 . 39947) (FINDLCA 39949 . 40170) (DOMINATE? 40172 . 40637))
(40640 47881 (POPSELECTION 40650 . 40821) (PUSHSELECTION 40823 . 40975) (NXTSELECTION 40977 . 41195) (
TOPSELECTION 41197 . 41414) (SWITCHANDSHADE 41416 . 41922) (SHADESELECTION 41924 . 42077) (
SHADESELECTION1 42079 . 43751) (SHADESELECTION2 43753 . 44064) (PUSHEDITCHAIN 44066 . 44365) (
MAKESELCHAIN 44367 . 45157) (PUSHINTOBUF 45159 . 45301) (DUMMYMAPENTRY 45303 . 45698) (FLIPSELS 45700
. 46127) (FLIPSELSIN 46129 . 46702) (FIXUPSEL 46704 . 47441) (NEWSELFOR 47443 . 47879)) (47882 54091
(ACTIVEEDITW 47892 . 48600) (FINDEDITW 48602 . 48785) (GETEDITW 48787 . 49320) (MAKEEDITW 49322 .
50093) (NAMEOFEDITW 50095 . 50715) (PURGEW 50717 . 51475) (MAKECPOSBE 51477 . 51894) (SAMEEDITW 51896
. 52129) (TOPEDITW 52131 . 52261) (UNDEDITW 52263 . 53517) (WHICHEDITW 53519 . 53826) (ZORCHEDITW
53828 . 54089)) (54092 62677 (BUFSELP 54102 . 54299) (EDITWINDOWP 54301 . 54532) (GETLEFT 54534 .
55000) (GETMEBP 55002 . 55160) (INTAILOF 55162 . 55682) (TAILOF 55684 . 55904) (DOTTEDEND 55906 .
56078) (GETME4 56080 . 56872) (GETSELMAP 56874 . 57206) (DEARME 57208 . 57749) (DPCDRSEL 57751 . 58055
) (GETDPME 58057 . 58242) (GETEBUF 58244 . 59843) (GETEDITCHAIN 59845 . 60333) (GETMAP 60335 . 60517)
(GETMAP? 60519 . 60743) (PURGEMAP 60745 . 60964) (PURGEDP 60966 . 61634) (SUBSELOF 61636 . 61918) (
SETDEDITMAP 61920 . 62527) (TAKEDOWN 62529 . 62675)) (62678 63399 (DEDITRESHAPEFN 62688 . 63006) (
DEDITSCROLLFN 63008 . 63202) (DEDITREPAINTFN 63204 . 63397)) (63400 72051 (SETEDITMENU 63410 . 65657)
(CACHEDEDITCOMS 65659 . 66846) (DEFDEDITCOM 66848 . 67846) (FINDEDITCOM 67848 . 68052) (READEDITMENU
68054 . 70620) (SHADEMENUENTRY 70622 . 71555) (DEDITMENURESTORE 71557 . 72049)) (72052 76429 (
RESETDEDIT 72062 . 75348) (DEDITDATE 75350 . 75723) (DEDITMARKASCHANGED 75725 . 76427)) (76430 77355 (
DEDITResetTypeComs 76440 . 77085) (DEDITTYPEDCOM 77087 . 77353)) (77356 77800 (COPYCONS 77366 . 77501)
(MAPENTRYP 77503 . 77647) (THELIST 77649 . 77798)) (77801 78323 (CANT 77811 . 78321)))))
STOP