; 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: jjacobs@well.UUCP ; ; 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))