Category : Files from Magazines
Archive   : AIOCT86.ZIP
Filename : ASSE.LSP

; A Simple Structure Editor (ASSE), Version 1.01
; by
; Jeffrey M. Jacobs
; Copyright (c) 1986, CONSART Systems Inc.
; All Rights Reserved.
; Permission granted for non-commercial distribution.

; CONSART Systems, Inc.
; P.O. Box 3016, Manhattan Beach, CA 90266
; (213)376-3802
; CompuServe: 75076,2603
; BIX: jeffjacobs
; USENET: [email protected]
;
; This is the code for the ASSE editor. In many respects, it is a cram course
; in LISP programming. Unlike some courses, this one starts out hard and gets
; easier. The code is laid out in roughly the order it was developed. The normal
; development cycle tends to be "middle out". Most of the early EDIT functions
; consist primarily of LISP primitives. As development progresses, common
; sequences of calls are made into functions. Normally we would go back and
; "fix" earlier functions to use the newer functions. This WILL be done in the
; electronically distributed version, but for "educational" (and schedule)
; reasons, it was left as is. So the "early" stuff is more difficult to
; read and understand.
;
; If you are new to LISP, it might be worthwhile to examine the code; there is
; a wide variety of LISP techniques used. The techniques, functions, forms
; etc. are pre-COMMON LISP (CL) and should work in any LISP, including .
; SCHEME. The only exception to this is DEFMACRO, which is NOT the same as the
; pre-CL MACRO (so much for the compatibility of CL). These are written to
; be easy to change to FEXPR's; just delete the &REST from the variable list.
;
; ASSE was developed using XLISP 1.6 on a Mac. Areas where you might need to
; change things are indicated by comments beginning with ";*". There aren't.
; many... - Jeff Jacobs, CONSART Systems Inc.

; The following functions are for convenience and readability

(DEFUN SUB1 (X) (1- X)) ;* I like SUB1.

(DEFUN NEQ (X Y) (NOT (EQ X Y))) ;* "NOT EQ"...

;* SPECIAL is not defined or available in XLISP.

(DEFMACRO SPECIAL (&REST X) (PUTPROP (CAR X) T 'SPECIAL) NIL) ;* XLISP.

;* Returns the function definition of an atom; NIL if undefined.
(DEFUN SYMBOL-FUNCTION (X) (SYMBOL-VALUE X)) ;* XLISP 1.6.

; MEMQ searches the list Y for an element EQ to X and returns the sublist
; starting with X. For XLISP and Common LISP, MEMBER uses EQL, which is close
; enough. Older LISP's MEMBER use EQUAL as the test, which is slower and
; could produce incorrect results.

(DEFUN MEMQ (X Y) (MEMBER X Y)) ;* XLISP and Common LISP

; Declare the global variables to be SPECIAL and initialize them.

(SPECIAL *UNDO_LIST*) ; Contains all the information from destructive
(SETQ *UNDO_LIST* NIL) ; operations, i.e. smash_lists, edit_indicators, etc.

(SPECIAL *EDIT_CHAIN*) ; Contains the "navigation" chain, i.e. the previous
(SETQ *EDIT_CHAIN* NIL) ; POSitions visited.

(SPECIAL *EDIT_PRINT_LEVEL*) ; The level to which the P command prints.
(SETQ *EDIT_PRINT_LEVEL* (QUOTE 2)) ; I like 2...

(SPECIAL *LAST_TAIL*) ; Used to keep for results of the UP command for
(SETQ *LAST_TAIL* NIL) ; the "...".

(SPECIAL *EDIT_LAST*) ; The SAVED_STATE of the last edit, if necessary.
(SETQ *EDIT_LAST* NIL)

; This is the entry into the guts of ASSE "User interface" functions call
; EDIT_LIST, which initializes and saves globals, faking dynamic binding,
; which is missing in some LISPs, such as XLISP and SCHEME. The caller
; is responsible for passing the correct initial states for the globals.
; Note that "break on error" should be disabled. You will have to figure
; out how this is done in your LISP.

(DEFUN EDIT_LIST
(EDIT_LIST UNDO_LIST)
(PROG (SAVE_STATE RETURN_STATE SAVE_BRK)
(SETQ SAVE_BRK *BREAKENABLE*)
(SETQ *BREAKENABLE* NIL) ;* Turns off "break on error" in XLISP.
(SETQ SAVE_STATE ; Save "current" values
(CONS *EDIT_CHAIN* *UNDO_LIST*) ) ; of globals.
(SETQ *EDIT_CHAIN* EDIT_LIST) ; Init
(SETQ *UNDO_LIST* UNDO_LIST) ; globals.
(SETQ RETURN_STATE ; Do the actual editing.
(LIST (EDIT_LIST1) *EDIT_CHAIN* *UNDO_LIST*) )
(SETQ *EDIT_CHAIN* (CAR SAVE_STATE)) ; Restore previous values
(SETQ *UNDO_LIST* (CDR SAVE_STATE)) ; of globals.
(SETQ *BREAKENABLE* SAVE_BRK) ; Restore state of"break on error".
(RETURN RETURN_STATE) ) )

; All EDIT_LIST1 does is READ the user command and perform the appropriate
; action,usually dispatching to a function. The ERRSET catches any errors
; generated by the user, preventing the user from inadvertently being thrown
; back to the top level of LISP. If you don't understand it, don't worry
; about it.

(DEFUN EDIT_LIST1
()
(PROG (COMMAND)
LOOP
(PRINC "*")
(SETQ COMMAND (EDIT_GET_CMD))
(ERRSET (COND ((NUMBERP COMMAND) (EDIT_SETTO_NTH COMMAND))
((MEMQ COMMAND '(D DEL DELETE))
(EDIT_DEL) )
((MEMQ COMMAND '(INSERT INS I))
(EDIT_INS_NTH) )
((EQ COMMAND 'OK)
(SETQ *EDIT_EDIT_CHAIN* (LAST *EDIT_CHAIN*))
(RETURN 'OK) )
((EQ COMMAND 'SAVE)
(SETQ *EDIT_CHAIN* (LAST *EDIT_CHAIN*))
(RETURN 'SAVE) )
((EQ COMMAND 'P)
(EDIT_PRINT (CAR *EDIT_CHAIN*)
*EDIT_PRINT_LEVEL* )
(TERPRI) )
((EQ COMMAND 'PL)
(EDIT_PRINT (EDIT_CUR_EXP) (EDIT_GET_ARG)) )
((MEMQ COMMAND '(EMB EMBED))
(EDIT_EMBED) )
((EQ COMMAND 'PP)
(PP (EDIT_CUR_EXP)) )
((MEMQ COMMAND '(R REP REPLACE))
(EDIT_REPLACE) )
((MEMQ COMMAND '(EXTRACT EXT XTR))
(EDIT_EXTRACT) )
((EQ COMMAND '??) (EDIT??))
((EQ COMMAND '?) (EDIT?))
((EQ COMMAND 'UP) (EDIT_UP))
((EQ COMMAND 'UNDO) (EDIT_UNDO))
((EQ COMMAND 'UNUNDO) (EDIT_UNUNDO))
((EQ COMMAND 'REVERT) (EDIT_REVERT))
((EQ COMMAND 'UNBLOCK) (EDIT_UNBLOCK))
((EQ COMMAND 'TOP)
(SETQ *EDIT_CHAIN* (LAST *EDIT_CHAIN*)) )
((MEMQ COMMAND '(NEXT NX N NEX))
(EDIT_NEXT) )
((EQ COMMAND 'TEST)
(SETQ *UNDO_LIST*
(CONS 'BLOCK *UNDO_LIST*) ) )
(T (EDIT_ERROR "?" COMMAND)) )
T )
(GO LOOP) ) )

; EDIT_SETTO_NTH should be worked through and understood. This function consists
; entirely of LISP primitives and is good exercise. Parts of this function
; are an obvious candidate for a separately defined function (see below).
; Note that there is only one form within the PROG.

(DEFUN EDIT_SETTO_NTH (N)
(PROG (CUR_EXP_LEN)
(COND ((ZEROP N)
(COND ((NULL (CDR *EDIT_CHAIN*))
(EDIT_ERROR "At TOP" 0) )
(T (SETQ *EDIT_CHAIN* (CDR *EDIT_CHAIN*))) ) )
((>= (SETQ CUR_EXP_LEN ; Save length of "current expression".
(LENGTH (CAR *EDIT_CHAIN*)) ) ;
(ABS N) )
(SETQ *EDIT_CHAIN*
(CONS (NTH (COND ((MINUSP N) (+ CUR_EXP_LEN N))
(T (SUB1 N)) )
(CAR *EDIT_CHAIN*) )
*EDIT_CHAIN* ) ) )
(T (EDIT_ERROR "?" N)) ) ) )

; The following function simply returns the "current expression". Otherwise
; we would have to look at miles and miles of (CAR *EDIT_CHAIN*). Makes
; the rest of the code easier to read.

(DEFUN EDIT_CUR_EXP NIL (CAR *EDIT_CHAIN*))

; EDIT_DEL simply dispatches to the appropriate function based on the
; value of the argument. Most of the functions called by EDIT_LIST1 dispatch
; this way; future versions will also dispatch on the type as well.

; WARNING: EDIT_DEL_CURRENT is not defined, but, if it were, would delete the
; current expression. Something for you to try; see UP and NEXT for hints.

(DEFUN EDIT_DEL ()
(PROG (N)
(COND ((NUMBERP (SETQ N (EDIT_GET_ARG))) ; User arg must be numeric.
(COND ((ZEROP N) (EDIT_DEL_CURRENT))
((EQ N 1) (EDIT_DEL_FIRST)) ; DEL 1 is a special case.
(T (EDIT_DEL_NTH N)) ) )
(T (EDIT_ERROR "DEL-bad arg" N)) ) ) )

; You should also work your way through EDIT_DEL_NTH. It deletes the nth
; element if it exists. Take careful note of the calculation for NTHCDR; it's
; tricky. Remember that the user specifies POSition "base 1", but NTHCDR is
; zero-based.

(DEFUN EDIT_DEL_NTH (N)
(PROG (CUR_EXP_LEN POS)
(SETQ CUR_EXP_LEN (LENGTH (EDIT_CUR_EXP)))
(COND ((MINUSP (SETQ POS N)) ; Convert user arg to "absolute" POSition.
(SETQ POS (+ CUR_EXP_LEN (+ 1 N))) ))
(COND ((= POS 1) (EDIT_DEL_FIRST)) ; DEL 1 is a special case.
((>= CUR_EXP_LEN POS)
(EDIT_SMASH (SETQ POS (NTHCDR (- POS 2) (EDIT_CUR_EXP)))
(CAR POS)
(CDDR POS) )
(EDIT_CMD_DONE (LIST 'DEL N)))
(T (EDIT_ERROR "DEL-bad arg" N)) ) ) )

; Even though this is a "special case", it's surprisingly simple.

(DEFUN EDIT_DEL_FIRST
NIL
(EDIT_SMASH (EDIT_CUR_EXP)
(CADR (EDIT_CUR_EXP))
(CDR (EDIT_CUR_EXP)) )
(EDIT_SMASH (EDIT_CUR_EXP)
(CAR (EDIT_CUR_EXP))
(CDDR (EDIT_CUR_EXP)) )
(EDIT_CMD_DONE (LIST 'DEL 1)) )

; Again, a simple dispatching function...

(DEFUN EDIT_INS_NTH
NIL
(PROG (WHAT ARG1 POS)
(SETQ WHAT (EDIT_GET_ARG))
(SETQ ARG1 (EDIT_GET_ARG))
(SETQ POS (EDIT_GET_ARG))
(COND ((NUMBERP POS)
(COND ((MEMQ ARG1 '(BEFORE BEF BF B))
(EDIT_INS_BEFORE WHAT POS) )
((MEMQ ARG1 '(AFTER AFT AF A))
(EDIT_INS_AFTER WHAT POS) )
(T (EDIT_ERROR "Arg to INSERT must be BEFORE or AFTER"
ARG1 )) ) )
(T (EDIT_ERROR "INSERT requires numeric arg"
POS )) ) ) )

; EDIT_INS_BEFORE illustrates insertion. Note the calculation of the POSition
; is now peformed by EDIT_VAL_NTH. Compare this with EDIT_DEL_NTH.

(DEFUN EDIT_INS_BEFORE (WHAT WHERE)
(PROG (POS Z)
(COND ((SETQ POS (EDIT_VAL_NTH WHERE))(SETQ POS (SUB1 POS))) ; Before...
(T(EDIT_ERROR "EDIT_INS_BEFORE-Illegal Position Specified" WHERE)))
(COND ((ZEROP POS)
(EDIT_SMASH (SETQ Z (EDIT_CUR_EXP)) WHAT (CONS (CAR Z) (CDR Z)))
(EDIT_CMD_DONE (LIST 'INSERT WHAT 'BEFORE WHERE)))
(T(EDIT_SMASH (SETQ Z (NTHCDR (SUB1 POS) (EDIT_CUR_EXP)))
(CAR Z)
(CONS WHAT (CDR Z)))
(EDIT_CMD_DONE (LIST 'INSERT WHAT 'BEFORE WHERE))))))

; EDIT_INS_AFTER...

(DEFUN EDIT_INS_AFTER (WHAT WHERE)
(PROG (POS Z)
(COND ((SETQ POS (EDIT_VAL_NTH WHERE)))
(T(EDIT_ERROR "EDIT_INS_AFTER-Illegal Position Specified" WHERE)))
(COND ((ZEROP POS)
(EDIT_SMASH (SETQ Z (EDIT_CUR_EXP)) WHAT (CONS (CAR Z) (CDR Z)))
(EDIT_CMD_DONE (LIST 'INSERT WHAT 'BEFORE WHERE)))
(T(EDIT_SMASH (SETQ Z (NTHCDR (SUB1 POS) (EDIT_CUR_EXP)))
(CAR Z)
(CONS WHAT (CDR Z)))
(EDIT_CMD_DONE (LIST 'INSERT WHAT 'AFTER WHERE))))))


; This is the workhorse of the editor. It takes the CONS cell to be modfied
; and the new CAR and CDR as it's arguments. It saves the information on
; *UNDO_LIST* and then "smashes" the cell using RPLACA and RPLACD.

(DEFUN EDIT_SMASH
(CELL NEW_CAR NEW_CDR)
(COND ((ATOM CELL)
(EDIT_ERROR "EDIT_SMASH-internal error, CELL must be CONS"
CELL ) )
(T (SETQ *UNDO_LIST*
(CONS (LIST CELL (CAR CELL) (CDR CELL))
*UNDO_LIST* ) )
(RPLACA CELL NEW_CAR)
(RPLACD CELL NEW_CDR) ) ) )

; This saves the current state of the edit chain and the command issued by the
; user on *UNDO_LIST*.

(DEFUN EDIT_CMD_DONE
(CMD) ; CMD is the "user's" command.
(SETQ *UNDO_LIST*
(CONS (CONS '*EDIT_CHAIN* *EDIT_CHAIN*)
*UNDO_LIST* ) )
(SETQ *UNDO_LIST* (CONS CMD *UNDO_LIST*)) )

; The following function would have been nice to have earlier. It takes
; a user supplied numerical argument and converts it to a positive, VALidated
; NTH position number for the current expression. It is a predicate (test)
; that returns a number if the argument was VALid, or NIL if something was
; wrong.

(DEFUN EDIT_VAL_NTH
(N)
(COND ((NUMBERP N) (EDIT_NTH N)) (T NIL)) )

; Convert a POSition number and verify that it's within the current expression's
; length. Called by EDIT_VAL_NTH.

(DEFUN EDIT_NTH
(N)
(PROG (POS CUR_EXP_LEN)
(SETQ CUR_EXP_LEN (LENGTH (EDIT_CUR_EXP)))
(COND ((MINUSP (SETQ POS N))
(SETQ POS (+ CUR_EXP_LEN (+ 1 N))) ))
(RETURN (COND ((>= CUR_EXP_LEN POS) POS) (T NIL))) ) )

; Embed things in parentheses. Calls a separate function to handle an arg of
; the type (n m).

(DEFUN EDIT_EMBED ()
(PROG (ARG POS TMP)
(COND ((AND (NUMBERP (SETQ ARG (EDIT_GET_ARG)))
(SETQ POS (EDIT_NTH ARG)) )
(EDIT_SMASH (SETQ TMP
(NTHCDR (SUB1 POS) (EDIT_CUR_EXP)) )
(CONS (CAR TMP) NIL)
(CDR TMP) ) )
((CONSP ARG) (EDIT_EMBD_RANGE ARG))
(T (EDIT_ERROR "EMBED-bad arg" ARG)) ) ) )

; Embed a range of elements in parentheses. Note the use of TMP1 and TMP2 to
; save values. Called by EDIT_EMBED.

(DEFUN EDIT_EMBD_RANGE (ARG)
(PROG (POS1 POS2 TMP1 TMP2)
(COND ((AND (SETQ POS1 (EDIT_VAL_NTH (CAR ARG)))
(SETQ POS2 (EDIT_VAL_NTH (CADR ARG)))
(> POS2 POS1) )
(EDIT_SMASH (SETQ TMP1
(NTHCDR (SUB1 POS1) (EDIT_CUR_EXP)) )
(CONS (CAR TMP1) (CDR TMP1))
(CDR (SETQ TMP2
(NTHCDR (SUB1 POS2) (EDIT_CUR_EXP)) )) )
(EDIT_SMASH TMP2 (CAR TMP2) NIL)
(EDIT_CMD_DONE (LIST 'EMBED ARG)) )
(T (EDIT_ERROR "EDIT_EMBD_RANGE-bad arg" ARG)) ) ) )

; Remove a set of parentheses from the element specified by ARG. This should
; hopefully be fairly straightforward by now. See the text and diagrams
; while examining the code...

(DEFUN EDIT_EXTRACT
NIL
(PROG (ARG POS CELL EXTRACTEE SAVE TMP)
(COND ((SETQ POS
(EDIT_VAL_NTH (SETQ ARG (EDIT_GET_ARG))) )
(SETQ CELL
(NTHCDR (SUB1 POS) (EDIT_CUR_EXP)) )
(COND ((CONSP (SETQ EXTRACTEE (CAR CELL)))
(EDIT_SMASH EXTRACTEE
(CAR EXTRACTEE)
(CDR EXTRACTEE) )
(COND ((NULL (CDR EXTRACTEE))
(EDIT_SMASH CELL (CAR EXTRACTEE) (CDR CELL)) )
(T (SETQ SAVE (CDR CELL))
(EDIT_SMASH CELL
(CAR EXTRACTEE)
(CDR EXTRACTEE) )
(EDIT_SMASH (SETQ TMP (LAST EXTRACTEE))
(CAR TMP)
SAVE ) ) )
(EDIT_CMD_DONE (LIST 'EXTRACT ARG)) )
(T (EDIT_ERROR "EDIT_EXTRACT-bad arg" ARG)) ) )) ) )

; This is about as simple as things get. It would be a lot messier if
; we used LISP primitives in place of EDIT_VAL_NTH...

(DEFUN EDIT_REPLACE
NIL
(PROG (WHERE WHAT POS TMP)
(SETQ WHERE (EDIT_GET_ARG))
(SETQ WHAT (EDIT_GET_ARG))
(COND ((SETQ POS (EDIT_VAL_NTH WHERE))
(EDIT_SMASH (SETQ TMP
(NTHCDR (SUB1 POS) (EDIT_CUR_EXP)) )
WHAT
(CDR TMP) )
(EDIT_CMD_DONE (LIST 'REPLACE WHERE WHAT)) )
(T (EDIT_ERROR "EDIT_REPLACE-bad arg" WHERE)) ) ) )

; Process the whole undo list and print out the user's commands. This
; demonstrates "classic" LISP MAP function useage. It applies (FUNCTION...
; to all of the CARs of *UNDO_LIST*. Very elegant. Note that the predicates
; EDIT_CMDP, EDIT_SMASHP and EDIT_CHAINP are defined below.

(DEFUN EDIT??
NIL
(MAPC (FUNCTION (LAMBDA (X)
(COND ((OR (EQ X 'BLOCK) (EDIT_CMDP X))
(PRINT X) )) ))
*UNDO_LIST* ) )


; EDIT? prints out a user specified number of commands. Just a simple loop...

(DEFUN EDIT?
NIL
(PROG (COUNT LIST)
(COND ((NOT (NUMBERP (SETQ COUNT (EDIT_GET_CMD))))
(EDIT_ERROR "EDIT?-bad arg" COUNT)
(RETURN NIL) ))
(SETQ LIST *UNDO_LIST*)
LOOP
(COND ((OR (NULL LIST) (ZEROP COUNT))
(RETURN NIL) )
((OR (EDIT_CMDP (CAR LIST))
(EQ (CAR LIST) 'BLOCK) )
(PRINT (CAR LIST))
(SETQ COUNT (SUB1 COUNT)) ) )
(SETQ LIST (CDR LIST))
(GO LOOP) ) )

; UP is explained in the text. See the diagram. Note that if the result is
; a "tail", or sublist, *LAST_TAIL* is set.

(DEFUN EDIT_UP
NIL
(PROG (CUR_EXP HGHR_EXP)
(COND ((NULL (SETQ HGHR_EXP (CADR *EDIT_CHAIN*)))
(EDIT_ERROR "Already at TOP" NIL) )
((EQ (SETQ CUR_EXP (EDIT_CUR_EXP))
(CAR HGHR_EXP) )
(SETQ *LAST_TAIL* NIL)
(SETQ *EDIT_CHAIN* (CDR *EDIT_CHAIN*)) )
((SETQ *LAST_TAIL* (MEMQ CUR_EXP HGHR_EXP))
(SETQ *EDIT_CHAIN*
(CONS *LAST_TAIL* (CDR *EDIT_CHAIN*)) ) )
((SETQ *EDIT_CHAIN* (CDR *EDIT_CHAIN*))) ) ) )

(DEFUN EDIT_NEXT
NIL
(PROG (HGHR_EXP TMP)
(COND ((NULL (SETQ HGHR_EXP (CADR *EDIT_CHAIN*)))
(EDIT_ERROR "No NEXT" NIL) )
((AND (SETQ TMP (MEMQ (EDIT_CUR_EXP) HGHR_EXP))
(CONSP (CDR TMP)) )
(SETQ *EDIT_CHAIN*
(CONS (CADR TMP) (CDR *EDIT_CHAIN*)) ) )
(T (EDIT_ERROR "No NEXT" NIL)) ) ) )

; The following 3 predicates are used when searching *UNDO_LIST*. EDIT_UNDOP,
; EDIT_SMASHP, and EDIT_CHAINP return "useful" values, i.e. either the
; undo list element if the predicate is true, or NIL if false.

; If X is an UNDO or UNUNDO command, return X, else NIL.

(DEFUN EDIT_UNDOP
(X)
(COND ((AND (CONSP X)
(MEMQ (CAR X) '(UNDO UNUNDO)) )
X )) )

; If X is a smash_list, return it, otherwise NIL.

(DEFUN EDIT_SMASHP
(X)
(COND ((AND (CONSP X) (CONSP (CAR X))) X)
(T NIL) ) )

; If X is a edit_chain indicator, return it, else NIL.

(DEFUN EDIT_CHAINP
(X)
(COND ((AND (CONSP X)
(EQ (CAR X) '*EDIT_CHAIN*) )
X )) )

; If X is a command, return T, not X, else NIL.

(DEFUN EDIT_CMDP
(X)
(AND (CONSP X)
(ATOM (CAR X))
(NEQ (CAR X) '*EDIT_CHAIN*) ) )

; EDIT_UNDO undoes the last destructive command that was not an "undo" command,
; unless a BLOCK intervenes (or there is nothing to undo). Note that UNDO
; is undoable by UNUNDO.

(DEFUN EDIT_UNDO ()
(PROG (TMPLIST TMPCAR)
(SETQ TMPLIST *UNDO_LIST*)
LOOP
(COND ((OR (NULL TMPLIST)
(EQ (SETQ TMPCAR (CAR TMPLIST))
'BLOCK ) )
(EDIT_ERROR "Nothing to UNDO" NIL) )
((AND (EDIT_CMDP TMPCAR) ; Must be a command
(NOT (EDIT_UNDOP TMPCAR)) ) ; but skip "undo" commands.
(COND ((EDIT_CHAINP (CADR TMPLIST)) ; Verify that *UNDO_LIST* is ok.
(EDIT_UNDO1 (CDDR TMPLIST)) ; Undo the previous command.
(EDIT_CMD_DONE (LIST 'UNDO)) ; Save the UNDO command.
(SETQ *EDIT_CHAIN* (CDADR TMPLIST)) ; Reset *EDIT_CHAIN*.
(PRINT (LIST TMPCAR 'UNDONE)) )
(T (EDIT_ERROR "EDIT_UNDO-Garbaged *UNDO_LIST*, BIG trouble"
NIL )) ) )
(T (SETQ TMPLIST (CDR TMPLIST)) (GO LOOP)) ) ) )

; EDIT_UNDO1 actually performs the "undoing", using EDIT_SMASH to allow UNUNDO.

(DEFUN EDIT_UNDO1
(LIST)
(PROG (TMP)
LOOP
(COND ((SETQ TMP (EDIT_SMASHP (CAR LIST)))
(EDIT_SMASH (CAR TMP)
(CADR TMP)
(CADDR TMP) )
(SETQ LIST (CDR LIST))
(GO LOOP) )) ) )

; UNUNDO undoes the last command if and only if it was an UNDO command.

(DEFUN EDIT_UNUNDO ()
(PROG (TMPLIST TMPCAR)
(COND ((OR (NULL (SETQ TMPLIST *UNDO_LIST*))
(EQ (SETQ TMPCAR (CAR TMPLIST))
'BLOCK ) )
(EDIT_ERROR "No UNDO to UNDO" NIL) )
((EDIT_UNDOP TMPCAR) ; Is it an "undo" command?
(COND ((EDIT_CHAINP (CADR TMPLIST)) ; Verify that *UNDO_LIST* is ok.
(EDIT_UNDO1 (CDDR TMPLIST)) ; Undo the UNDO.
(EDIT_CMD_DONE (LIST 'UNUNDO)) ; Save the UNUNDO command.
(SETQ *EDIT_CHAIN* (CDADR TMPLIST)) ; Restore *EDIT_CHAIN*.
(PRINT (LIST TMPCAR 'UNDONE)) )
(T (EDIT_ERROR "EDIT_UNDO-Garbaged *UNDO_LIST*, BIG trouble"
NIL )) ) )
(T (EDIT_ERROR "Last command was not UNDO" NIL)) ) ) )

; EDIT_REVERT restores everything that was done since the last TEST/BLOCK was
; issued. REVERT is NOT undoable...

(DEFUN EDIT_REVERT
NIL
(PRINC "Are you SURE?")
(COND ((MEMQ (READ) '(Y YE YES))
(PROG (TMPLIST TMPCAR)
(SETQ TMPLIST *UNDO_LIST*)
LOOP
(COND ((OR (NULL TMPLIST)
(EQ (SETQ TMPCAR (CAR TMPLIST))
'BLOCK ) )
(SETQ *UNDO_LIST* TMPLIST)
(RETURN NIL) )
((EDIT_SMASHP TMPCAR)
(RPLACA (CAR TMPCAR) (CADR TMPCAR))
(RPLACD (CAR TMPCAR) (CADDR TMPCAR)) )
((EDIT_CHAINP TMPCAR)
(SETQ *EDIT_CHAIN* (CDR TMPCAR)) ) )
(SETQ TMPLIST (CDR TMPLIST))
(GO LOOP) ) )) )

; Destructively removes a BLOCK from *UNDO_LIST*

(DEFUN EDIT_UNBLOCK
NIL
(PROG (TMPLIST)
(COND ((NULL (SETQ TMPLIST *UNDO_LIST*)) ; Check for nothing on
(RETURN NIL) ) ; the list,
((EQ (CAR *UNDO_LIST*) (QUOTE BLOCK)) ; or for BLOCK at the
(SETQ *UNDO_LIST* (CDR *UNDO_LIST*)) ) ) ; begining.
LOOP
(COND ((EQ (CADR TMPLIST) (QUOTE BLOCK)) ; If BLOCK found,
(RPLACD TMPLIST (CDDR TMPLIST)) ; remove it from the list.
(RETURN NIL) )
((SETQ TMPLIST (CDR TMPLIST)) (GO LOOP)) ; Keep searching.
(T (EDIT_ERROR "No BLOCK found" NIL)) ) ) ) ; Report error.


; The User Interface functions follow. They are adequately described in the
; text. If your LISP is "old" and doesn't support DEFMACRO, just change it
; to a FEXPR and remove the &REST.

; NOTE that getting the function definition varies ridiculously from dialect
; to dialect. In NIL, it's
;
; (SI:INTERPRETER-CLOSURE-LAMBDA (SYMBOL-FUNCTION FUN))
;
; You will have to change this for your LISP. It shouldn't be as bad as NIL.
; If there is both a function definition and a saved state, EDITF assumes
; the saved state is the function. (It probably should verify this...).


(DEFMACRO EDITF
(&REST FUN)
(SETQ FUN (CAR FUN)) ; Get the function name.
(PROG (FUNDEF RESULT SAVED_STATE)
(COND ((NULL (SETQ FUNDEF (SYMBOL-FUNCTION FUN))) ;*Change this?
(PRINT (LIST "No function definition for" FUN))
(RETURN NIL) )
((SETQ SAVED_STATE
(GET FUN 'EDIT_SAVE) )
(SETQ RESULT
(EDIT_LIST (CAR SAVED_STATE)
(CADR SAVED_STATE) ) ) )
(T (SETQ RESULT
(EDIT_LIST (CONS FUNDEF NIL) NIL) )) )
(COND ((EQ (CAR RESULT) 'OK)
(REMPROP FUN 'EDIT_SAVE)
(PUTPROP '*EDIT_LAST* (CDR RESULT) 'EDIT_SAVE)
(RETURN (LIST 'QUOTE FUN)) )
((EQ (CAR RESULT) 'SAVE)
(PUTPROP FUN (CDR RESULT) 'EDIT_SAVE)
(RETURN (LIST 'QUOTE FUN)) )
(T (PRINT "Unknown return from EDIT_LIST")
NIL ) ) ) )

; EDITV is roughly the same as EDITF. Note that in XLISP 1.6 they are the
; same. As before, if you have "old" LISP, change to a FEXPR...

(DEFMACRO EDITV
(&REST VAR)
(SETQ VAR (CAR VAR))
(PROG (VALUE RESULT SAVED_STATE)
(COND ((ATOM (SETQ VALUE (SYMBOL-VALUE VAR)))
(PRINT (LIST "Value cannot be edited for" VAR))
(RETURN NIL) )
((SETQ SAVED_STATE
(GET VAR 'EDIT_SAVE) )
(SETQ RESULT
(EDIT_LIST (CAR SAVED_STATE)
(CADR SAVED_STATE) ) ) )
(T (SETQ RESULT
(EDIT_LIST (CONS VALUE NIL) NIL) )) )
(COND ((EQ (CAR RESULT) 'OK)
(REMPROP VAR 'EDIT_SAVE)
(PUTPROP '*EDIT_LAST* (CDR RESULT) 'EDIT_SAVE)
(RETURN (LIST 'QUOTE VAR)) )
((EQ (CAR RESULT) 'SAVE)
(PUTPROP VAR (CDR RESULT) 'EDIT_SAVE)
(RETURN (LIST 'QUOTE VAR)) )
(T (PRINT "Unknown return from EDIT_LIST")
NIL ) ) ) )

(DEFUN EDIT
(EXPR)
(PROG (RESULT SAVED_STATE)
(COND ((NULL EXPR)
(COND ((SETQ SAVED_STATE
(GET '*EDIT_LAST* 'EDIT_SAVE) )
(SETQ RESULT
(EDIT_LIST (CAR SAVED_STATE)
(CADR SAVED_STATE) ) ) )) )
((CONSP EXPR)
(SETQ RESULT
(EDIT_LIST (CONS EXPR NIL) NIL) ) )
(T (PRINT "Nothing to EDIT") (RETURN NIL)) )
(PUTPROP '*EDIT_LAST* (CDR RESULT) 'EDIT_SAVE)
(RETURN (CAR (LAST (CADR RESULT)))) ) )

; This causes everything between the invocation of EDIT_ERROR and the
; ERRSET in EDIT_LIST1 to be thrown away.

(DEFUN EDIT_ERROR
(STRING ARG)
(ERROR STRING ARG)
NIL )

; The I/O functions follow:

(DEFUN EDIT_PRINT
(EXPR DEPTH)
(COND ((EQ EXPR *LAST_TAIL*) (PRINC "...")))
(PRINT_LEV EXPR DEPTH) )

(DEFUN PRINT_LEV
(EXPR DEPTH)
(COND ((ATOM EXPR) (PRIN1 EXPR))
((CONSP EXPR)
(COND ((ZEROP DEPTH) (PRIN1 '&))
(T (PRINC "(")
(PRINT_LEV1 EXPR DEPTH)
(PRINC ")") ) ) ) ) )

(DEFUN PRINT_LEV1
(EXPR DEPTH)
(PROG (X)
(SETQ X EXPR)
LOOP
(COND ((ATOM (CAR X)) (PRIN1 (CAR X)))
(T (PRINT_LEV (CAR X) (- DEPTH 1))) )
(COND ((NULL (SETQ X (CDR X))) (RETURN))
(T (PRINC " ") (GO LOOP)) ) ) )

; Just a simple READ protected by an ERRSET to prevent accidental exits
; from the editor or a user induced break.

(DEFUN EDIT_GET_CMD
NIL
(PROG (X)
LOOP
(COND ((SETQ X (ERRSET (READ) NIL))
(RETURN (CAR X)) )
(T (PRINC "*") (GO LOOP)) ) ) )

(DEFUN EDIT_GET_ARG NIL (READ))