home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / aijournl / 1986_10 / asse.lsp < prev    next >
Text File  |  1986-09-20  |  31KB  |  707 lines
  1. ;        A Simple Structure Editor (ASSE), Version 1.01
  2. ;            by
  3. ;        Jeffrey M. Jacobs
  4. ;        Copyright (c) 1986, CONSART Systems Inc.
  5. ;        All Rights Reserved.
  6. ;        Permission granted for non-commercial distribution.
  7.  
  8. ;        CONSART Systems, Inc.
  9. ;        P.O. Box 3016, Manhattan Beach, CA 90266
  10. ;        (213)376-3802
  11. ;        CompuServe: 75076,2603
  12. ;        BIX: jeffjacobs
  13. ;        USENET: jjacobs@well.UUCP
  14. ;
  15. ; This is the code for the ASSE editor.  In many respects, it is a cram course
  16. ; in LISP programming.  Unlike some courses, this one starts out hard and gets
  17. ; easier. The code is laid out in roughly the order it was developed. The normal
  18. ; development cycle tends to be "middle out". Most of the early EDIT functions
  19. ; consist primarily of LISP primitives.  As development progresses, common
  20. ; sequences of calls are made into functions.  Normally we would go back and
  21. ; "fix" earlier functions to use the newer functions.  This WILL be done in the
  22. ; electronically distributed version, but for "educational" (and schedule)
  23. ; reasons, it was left as is.  So the "early" stuff is more difficult to
  24. ; read and understand.
  25. ;
  26. ; If you are new to LISP, it might be worthwhile to examine the code; there is
  27. ; a wide variety of LISP techniques used.  The techniques, functions, forms
  28. ; etc. are pre-COMMON LISP (CL) and should work in any LISP, including .
  29. ; SCHEME. The only exception to this is DEFMACRO, which is NOT the same as the
  30. ; pre-CL MACRO (so much for the compatibility of CL).  These are written to
  31. ; be easy to change to FEXPR's; just delete the &REST from the variable list.
  32. ;
  33. ; ASSE was developed using XLISP 1.6 on a Mac.  Areas where you might need to
  34. ; change things are indicated by comments beginning with ";*".  There aren't.
  35. ; many...                       - Jeff Jacobs, CONSART Systems Inc.
  36.  
  37. ; The following functions are for convenience and readability
  38.  
  39. (DEFUN SUB1 (X) (1- X))    ;* I like SUB1.
  40.  
  41. (DEFUN NEQ (X Y) (NOT (EQ X Y))) ;* "NOT EQ"...
  42.  
  43. ;* SPECIAL is not defined or available in XLISP.
  44.  
  45. (DEFMACRO SPECIAL (&REST X) (PUTPROP (CAR X) T 'SPECIAL) NIL)  ;* XLISP.
  46.  
  47. ;* Returns the function definition of an atom; NIL if undefined.
  48. (DEFUN SYMBOL-FUNCTION (X) (SYMBOL-VALUE X)) ;* XLISP 1.6.
  49.  
  50. ; MEMQ searches the list Y for an element EQ to X and returns the sublist
  51. ; starting with X.  For XLISP and Common LISP, MEMBER uses EQL, which is close
  52. ; enough.  Older LISP's MEMBER use EQUAL as the test, which is slower and
  53. ; could produce incorrect results.
  54.  
  55. (DEFUN MEMQ (X Y) (MEMBER X Y)) ;* XLISP and Common LISP 
  56.  
  57. ; Declare the global variables to be SPECIAL and initialize them.
  58.  
  59. (SPECIAL *UNDO_LIST*)    ; Contains all the information from destructive
  60. (SETQ *UNDO_LIST* NIL)    ; operations, i.e. smash_lists, edit_indicators, etc.
  61.  
  62. (SPECIAL *EDIT_CHAIN*)    ; Contains the "navigation" chain, i.e. the previous
  63. (SETQ *EDIT_CHAIN* NIL) ; POSitions visited.
  64.  
  65. (SPECIAL *EDIT_PRINT_LEVEL*) ; The level to which the P command prints.
  66. (SETQ *EDIT_PRINT_LEVEL* (QUOTE 2)) ; I like 2...
  67.  
  68. (SPECIAL *LAST_TAIL*)    ; Used to keep for results of the UP command for
  69. (SETQ *LAST_TAIL* NIL)    ; the "...".
  70.  
  71. (SPECIAL *EDIT_LAST*)    ; The SAVED_STATE of the last edit, if necessary.    
  72. (SETQ *EDIT_LAST* NIL)
  73.  
  74. ; This is the entry into the guts of ASSE  "User interface" functions call
  75. ; EDIT_LIST, which initializes and saves globals, faking dynamic binding,
  76. ; which is missing in some LISPs, such as XLISP and SCHEME.  The caller
  77. ; is responsible for passing the correct initial states for the globals.
  78. ; Note that "break on error" should be disabled.  You will have to figure
  79. ; out how this is done in your LISP.
  80.  
  81. (DEFUN EDIT_LIST
  82.        (EDIT_LIST UNDO_LIST)
  83.        (PROG (SAVE_STATE RETURN_STATE SAVE_BRK)
  84.              (SETQ SAVE_BRK *BREAKENABLE*)
  85.              (SETQ *BREAKENABLE* NIL)    ;* Turns off "break on error" in XLISP.
  86.              (SETQ SAVE_STATE        ; Save "current" values
  87.                    (CONS *EDIT_CHAIN* *UNDO_LIST*) ) ;  of globals.
  88.              (SETQ *EDIT_CHAIN* EDIT_LIST) ; Init 
  89.              (SETQ *UNDO_LIST* UNDO_LIST)  ; globals.
  90.              (SETQ RETURN_STATE           ; Do the actual editing.
  91.                    (LIST (EDIT_LIST1) *EDIT_CHAIN* *UNDO_LIST*) )
  92.              (SETQ *EDIT_CHAIN* (CAR SAVE_STATE)) ; Restore previous values
  93.              (SETQ *UNDO_LIST* (CDR SAVE_STATE))  ; of globals.    
  94.              (SETQ *BREAKENABLE* SAVE_BRK) ; Restore state of"break on error".
  95.              (RETURN RETURN_STATE) ) )
  96.  
  97. ; All EDIT_LIST1 does is READ the user command and perform the appropriate
  98. ; action,usually dispatching to a function. The ERRSET catches any errors
  99. ; generated by the user, preventing the user from inadvertently being thrown
  100. ; back to the top level of LISP. If you don't understand it,  don't worry 
  101. ; about it.
  102.  
  103. (DEFUN EDIT_LIST1
  104.        ()
  105.        (PROG (COMMAND)
  106.              LOOP
  107.              (PRINC "*")
  108.              (SETQ COMMAND (EDIT_GET_CMD))
  109.              (ERRSET (COND ((NUMBERP COMMAND) (EDIT_SETTO_NTH COMMAND))
  110.                            ((MEMQ COMMAND '(D DEL DELETE))
  111.                             (EDIT_DEL) )
  112.                            ((MEMQ COMMAND '(INSERT INS I))
  113.                             (EDIT_INS_NTH) )
  114.                            ((EQ COMMAND 'OK)
  115.                             (SETQ *EDIT_EDIT_CHAIN* (LAST *EDIT_CHAIN*))
  116.                             (RETURN 'OK) )
  117.                            ((EQ COMMAND 'SAVE)
  118.                             (SETQ *EDIT_CHAIN* (LAST *EDIT_CHAIN*))
  119.                             (RETURN 'SAVE) )
  120.                            ((EQ COMMAND 'P)
  121.                             (EDIT_PRINT (CAR *EDIT_CHAIN*)
  122.                                         *EDIT_PRINT_LEVEL* )
  123.                             (TERPRI) )
  124.                            ((EQ COMMAND 'PL)
  125.                             (EDIT_PRINT (EDIT_CUR_EXP) (EDIT_GET_ARG)) )
  126.                            ((MEMQ COMMAND '(EMB EMBED))
  127.                             (EDIT_EMBED) )
  128.                            ((EQ COMMAND 'PP)
  129.                             (PP (EDIT_CUR_EXP)) )
  130.                            ((MEMQ COMMAND '(R REP REPLACE))
  131.                             (EDIT_REPLACE) )
  132.                            ((MEMQ COMMAND '(EXTRACT EXT XTR))
  133.                             (EDIT_EXTRACT) )
  134.                            ((EQ COMMAND '??) (EDIT??))
  135.                            ((EQ COMMAND '?) (EDIT?))
  136.                            ((EQ COMMAND 'UP) (EDIT_UP))
  137.                            ((EQ COMMAND 'UNDO) (EDIT_UNDO))
  138.                            ((EQ COMMAND 'UNUNDO) (EDIT_UNUNDO))
  139.                            ((EQ COMMAND 'REVERT) (EDIT_REVERT))
  140.                            ((EQ COMMAND 'UNBLOCK) (EDIT_UNBLOCK))
  141.                            ((EQ COMMAND 'TOP)
  142.                             (SETQ *EDIT_CHAIN* (LAST *EDIT_CHAIN*)) )
  143.                            ((MEMQ COMMAND '(NEXT NX N NEX))
  144.                             (EDIT_NEXT) )
  145.                            ((EQ COMMAND 'TEST)
  146.                             (SETQ *UNDO_LIST*
  147.                                   (CONS 'BLOCK *UNDO_LIST*) ) )
  148.                            (T (EDIT_ERROR "?" COMMAND)) )
  149.                      T )
  150.              (GO LOOP) ) )
  151.  
  152. ; EDIT_SETTO_NTH should be worked through and understood. This function consists
  153. ; entirely of LISP primitives and is good exercise.  Parts of this function
  154. ; are an obvious candidate for a separately defined function (see below).
  155. ; Note that there is only one form within the PROG.
  156.  
  157. (DEFUN EDIT_SETTO_NTH (N)
  158.     (PROG (CUR_EXP_LEN)
  159.           (COND ((ZEROP N)
  160.                  (COND ((NULL (CDR *EDIT_CHAIN*))
  161.                         (EDIT_ERROR "At TOP" 0) )
  162.                        (T (SETQ *EDIT_CHAIN* (CDR *EDIT_CHAIN*))) ) )
  163.                 ((>= (SETQ CUR_EXP_LEN    ; Save length of "current expression".
  164.                            (LENGTH (CAR *EDIT_CHAIN*)) ) ;
  165.                      (ABS N) )
  166.                  (SETQ *EDIT_CHAIN*
  167.                        (CONS (NTH (COND ((MINUSP N) (+ CUR_EXP_LEN N))
  168.                                         (T (SUB1 N)) )
  169.                                   (CAR *EDIT_CHAIN*) )
  170.                              *EDIT_CHAIN* ) ) )
  171.                 (T (EDIT_ERROR "?" N)) ) ) )
  172.  
  173. ; The following function simply returns the "current expression".  Otherwise
  174. ; we would have to look at miles and miles of (CAR *EDIT_CHAIN*).  Makes
  175. ; the rest of the code easier to read.
  176.  
  177. (DEFUN EDIT_CUR_EXP NIL (CAR *EDIT_CHAIN*))
  178.  
  179. ; EDIT_DEL simply dispatches to the appropriate function based on the
  180. ; value of the argument. Most of the functions called by EDIT_LIST1 dispatch
  181. ; this way; future versions will also dispatch on the type as well.
  182.  
  183. ; WARNING: EDIT_DEL_CURRENT is not defined, but, if it were, would delete the 
  184. ; current expression.  Something for you to try; see UP and NEXT for hints.
  185.  
  186. (DEFUN EDIT_DEL ()
  187.     (PROG (N)
  188.           (COND ((NUMBERP (SETQ N (EDIT_GET_ARG))) ; User arg must be numeric.
  189.                  (COND ((ZEROP N) (EDIT_DEL_CURRENT))
  190.                        ((EQ N 1) (EDIT_DEL_FIRST)) ; DEL 1 is a special case.
  191.                        (T (EDIT_DEL_NTH N)) ) )
  192.                 (T (EDIT_ERROR "DEL-bad arg" N)) ) ) )
  193.  
  194. ; You should also work your way through EDIT_DEL_NTH.  It deletes the nth 
  195. ; element if it exists.  Take careful note of the calculation for NTHCDR; it's
  196. ; tricky. Remember that the user specifies POSition "base 1", but NTHCDR is
  197. ; zero-based.
  198.  
  199. (DEFUN EDIT_DEL_NTH (N)
  200.   (PROG (CUR_EXP_LEN POS)
  201.         (SETQ CUR_EXP_LEN (LENGTH (EDIT_CUR_EXP)))
  202.         (COND ((MINUSP (SETQ POS N))  ; Convert user arg to "absolute" POSition.
  203.                (SETQ POS (+ CUR_EXP_LEN (+ 1 N))) ))
  204.         (COND ((= POS 1) (EDIT_DEL_FIRST)) ; DEL 1 is a special case.
  205.               ((>= CUR_EXP_LEN POS)
  206.                (EDIT_SMASH (SETQ POS (NTHCDR (- POS 2) (EDIT_CUR_EXP)))
  207.                            (CAR POS)
  208.                            (CDDR POS) )
  209.                (EDIT_CMD_DONE (LIST 'DEL N)))
  210.               (T (EDIT_ERROR "DEL-bad arg" N)) ) ) )
  211.  
  212. ; Even though this is a "special case", it's surprisingly simple.
  213.  
  214. (DEFUN EDIT_DEL_FIRST
  215.        NIL
  216.        (EDIT_SMASH (EDIT_CUR_EXP)
  217.                    (CADR (EDIT_CUR_EXP))
  218.                    (CDR (EDIT_CUR_EXP)) )
  219.        (EDIT_SMASH (EDIT_CUR_EXP)
  220.                    (CAR (EDIT_CUR_EXP))
  221.                    (CDDR (EDIT_CUR_EXP)) )
  222.        (EDIT_CMD_DONE (LIST 'DEL 1)) )
  223.  
  224. ; Again, a simple dispatching function...
  225.  
  226. (DEFUN EDIT_INS_NTH
  227.        NIL
  228.        (PROG (WHAT ARG1 POS)
  229.              (SETQ WHAT (EDIT_GET_ARG))
  230.              (SETQ ARG1 (EDIT_GET_ARG))
  231.              (SETQ POS (EDIT_GET_ARG))
  232.              (COND ((NUMBERP POS)
  233.                     (COND ((MEMQ ARG1 '(BEFORE BEF BF B))
  234.                            (EDIT_INS_BEFORE WHAT POS) )
  235.                           ((MEMQ ARG1 '(AFTER AFT AF A))
  236.                            (EDIT_INS_AFTER WHAT POS) )
  237.                           (T (EDIT_ERROR "Arg to INSERT must be BEFORE or AFTER"
  238.                                          ARG1 )) ) )
  239.                    (T (EDIT_ERROR "INSERT requires numeric arg"
  240.                                   POS )) ) ) )
  241.  
  242. ; EDIT_INS_BEFORE illustrates insertion.  Note the calculation of the POSition
  243. ; is now peformed by EDIT_VAL_NTH.  Compare this with EDIT_DEL_NTH.
  244.  
  245. (DEFUN EDIT_INS_BEFORE (WHAT WHERE)
  246.  (PROG (POS Z)
  247.        (COND ((SETQ POS (EDIT_VAL_NTH WHERE))(SETQ POS (SUB1 POS))) ; Before...
  248.              (T(EDIT_ERROR "EDIT_INS_BEFORE-Illegal Position Specified" WHERE)))
  249.        (COND ((ZEROP POS)
  250.               (EDIT_SMASH (SETQ Z (EDIT_CUR_EXP))  WHAT  (CONS (CAR Z) (CDR Z)))
  251.               (EDIT_CMD_DONE (LIST 'INSERT WHAT 'BEFORE  WHERE)))
  252.              (T(EDIT_SMASH (SETQ Z (NTHCDR (SUB1 POS) (EDIT_CUR_EXP)))
  253.                            (CAR Z)
  254.                            (CONS WHAT (CDR Z)))
  255.                (EDIT_CMD_DONE (LIST 'INSERT WHAT 'BEFORE WHERE))))))
  256.  
  257. ; EDIT_INS_AFTER...
  258.  
  259. (DEFUN EDIT_INS_AFTER (WHAT WHERE)
  260.  (PROG (POS Z)
  261.        (COND ((SETQ POS (EDIT_VAL_NTH WHERE)))
  262.              (T(EDIT_ERROR "EDIT_INS_AFTER-Illegal Position Specified" WHERE)))
  263.        (COND ((ZEROP POS)
  264.               (EDIT_SMASH (SETQ Z (EDIT_CUR_EXP))  WHAT  (CONS (CAR Z) (CDR Z)))
  265.               (EDIT_CMD_DONE (LIST 'INSERT WHAT 'BEFORE  WHERE)))
  266.              (T(EDIT_SMASH (SETQ Z (NTHCDR (SUB1 POS) (EDIT_CUR_EXP)))
  267.                            (CAR Z)
  268.                            (CONS WHAT (CDR Z)))
  269.                (EDIT_CMD_DONE (LIST 'INSERT WHAT 'AFTER WHERE))))))
  270.  
  271.  
  272. ; This is the workhorse of the editor.  It takes the CONS cell to be modfied
  273. ; and the new CAR and CDR as it's arguments.  It saves the information on
  274. ; *UNDO_LIST* and then "smashes" the cell using RPLACA and RPLACD.
  275.  
  276. (DEFUN EDIT_SMASH
  277.        (CELL NEW_CAR NEW_CDR)
  278.        (COND ((ATOM CELL)
  279.               (EDIT_ERROR "EDIT_SMASH-internal error, CELL must be CONS"
  280.                           CELL ) )
  281.              (T (SETQ *UNDO_LIST*
  282.                       (CONS (LIST CELL (CAR CELL) (CDR CELL))
  283.                             *UNDO_LIST* ) )
  284.                 (RPLACA CELL NEW_CAR)
  285.                 (RPLACD CELL NEW_CDR) ) ) )
  286.  
  287. ; This saves the current state of the edit chain and the command issued by the
  288. ; user on *UNDO_LIST*.
  289.  
  290. (DEFUN EDIT_CMD_DONE
  291.        (CMD)    ; CMD is the "user's" command.
  292.        (SETQ *UNDO_LIST*
  293.              (CONS (CONS '*EDIT_CHAIN* *EDIT_CHAIN*)
  294.                    *UNDO_LIST* ) )
  295.        (SETQ *UNDO_LIST* (CONS CMD *UNDO_LIST*)) )
  296.  
  297. ; The following function would have been nice to have earlier.  It takes
  298. ; a user supplied numerical argument and converts it to a positive, VALidated
  299. ; NTH position number for the current expression.  It is a predicate (test)
  300. ; that returns a number if the argument was VALid, or NIL if something was
  301. ; wrong.
  302.  
  303. (DEFUN EDIT_VAL_NTH
  304.        (N)
  305.        (COND ((NUMBERP N) (EDIT_NTH N)) (T NIL)) )
  306.  
  307. ; Convert a POSition number and verify that it's within the current expression's
  308. ; length.  Called by EDIT_VAL_NTH.
  309.  
  310. (DEFUN EDIT_NTH
  311.        (N)
  312.        (PROG (POS CUR_EXP_LEN)
  313.              (SETQ CUR_EXP_LEN (LENGTH (EDIT_CUR_EXP)))
  314.              (COND ((MINUSP (SETQ POS N))
  315.                     (SETQ POS (+ CUR_EXP_LEN (+ 1 N))) ))
  316.              (RETURN (COND ((>= CUR_EXP_LEN POS) POS) (T NIL))) ) )
  317.  
  318. ; Embed things in parentheses.  Calls a separate function to handle an arg of
  319. ; the type (n m).
  320.  
  321. (DEFUN EDIT_EMBED ()
  322.        (PROG (ARG POS TMP)
  323.              (COND ((AND (NUMBERP (SETQ ARG (EDIT_GET_ARG)))
  324.                          (SETQ POS (EDIT_NTH ARG)) )
  325.                     (EDIT_SMASH (SETQ TMP
  326.                                       (NTHCDR (SUB1 POS) (EDIT_CUR_EXP)) )
  327.                                 (CONS (CAR TMP) NIL)
  328.                                 (CDR TMP) ) )
  329.                    ((CONSP ARG) (EDIT_EMBD_RANGE ARG))
  330.                    (T (EDIT_ERROR "EMBED-bad arg" ARG)) ) ) )
  331.                    
  332. ; Embed a range of elements in parentheses.  Note the use of TMP1 and TMP2 to
  333. ; save values.  Called by EDIT_EMBED.
  334.  
  335. (DEFUN EDIT_EMBD_RANGE (ARG)
  336.    (PROG (POS1 POS2 TMP1 TMP2)
  337.     (COND ((AND (SETQ POS1 (EDIT_VAL_NTH (CAR ARG)))
  338.                      (SETQ POS2 (EDIT_VAL_NTH (CADR ARG)))
  339.                      (> POS2 POS1) )
  340.                 (EDIT_SMASH (SETQ TMP1
  341.                                   (NTHCDR (SUB1 POS1) (EDIT_CUR_EXP)) )
  342.                             (CONS (CAR TMP1) (CDR TMP1))
  343.                             (CDR (SETQ TMP2
  344.                                        (NTHCDR (SUB1 POS2) (EDIT_CUR_EXP)) )) )
  345.                 (EDIT_SMASH TMP2 (CAR TMP2) NIL)
  346.                 (EDIT_CMD_DONE (LIST 'EMBED ARG)) )
  347.                (T (EDIT_ERROR "EDIT_EMBD_RANGE-bad arg" ARG)) ) ) )
  348.  
  349. ; Remove a set of parentheses from the element specified by ARG. This should
  350. ; hopefully be fairly straightforward by now.  See the text and diagrams
  351. ; while examining the code...
  352.  
  353. (DEFUN EDIT_EXTRACT
  354.        NIL
  355.        (PROG (ARG POS CELL EXTRACTEE SAVE TMP)
  356.              (COND ((SETQ POS
  357.                           (EDIT_VAL_NTH (SETQ ARG (EDIT_GET_ARG))) )
  358.                     (SETQ CELL
  359.                           (NTHCDR (SUB1 POS) (EDIT_CUR_EXP)) )
  360.                     (COND ((CONSP (SETQ EXTRACTEE (CAR CELL)))
  361.                            (EDIT_SMASH EXTRACTEE
  362.                                        (CAR EXTRACTEE)
  363.                                        (CDR EXTRACTEE) )
  364.                            (COND ((NULL (CDR EXTRACTEE))
  365.                                   (EDIT_SMASH CELL (CAR EXTRACTEE) (CDR CELL)) )
  366.                                  (T (SETQ SAVE (CDR CELL))
  367.                                     (EDIT_SMASH CELL
  368.                                                 (CAR EXTRACTEE)
  369.                                                 (CDR EXTRACTEE) )
  370.                                     (EDIT_SMASH (SETQ TMP (LAST EXTRACTEE))
  371.                                                 (CAR TMP)
  372.                                                 SAVE ) ) )
  373.                            (EDIT_CMD_DONE (LIST 'EXTRACT ARG)) )
  374.                           (T (EDIT_ERROR "EDIT_EXTRACT-bad arg" ARG)) ) )) ) )
  375.  
  376. ; This is about as simple as things get.  It would be a lot messier if
  377. ; we used LISP primitives in place of EDIT_VAL_NTH...
  378.  
  379. (DEFUN EDIT_REPLACE
  380.        NIL
  381.        (PROG (WHERE WHAT POS TMP)
  382.              (SETQ WHERE (EDIT_GET_ARG))
  383.              (SETQ WHAT (EDIT_GET_ARG))
  384.              (COND ((SETQ POS (EDIT_VAL_NTH WHERE))
  385.                     (EDIT_SMASH (SETQ TMP
  386.                                       (NTHCDR (SUB1 POS) (EDIT_CUR_EXP)) )
  387.                                 WHAT
  388.                                 (CDR TMP) )
  389.                     (EDIT_CMD_DONE (LIST 'REPLACE WHERE WHAT)) )
  390.                    (T (EDIT_ERROR "EDIT_REPLACE-bad arg" WHERE)) ) ) )
  391.  
  392. ; Process the whole undo list and print out the user's commands.  This
  393. ; demonstrates "classic" LISP MAP function useage.  It applies (FUNCTION...
  394. ; to all of the CARs of *UNDO_LIST*.  Very elegant.  Note that the predicates
  395. ; EDIT_CMDP, EDIT_SMASHP and EDIT_CHAINP are defined below.
  396.  
  397. (DEFUN EDIT??
  398.        NIL
  399.        (MAPC (FUNCTION (LAMBDA (X)
  400.                                (COND ((OR (EQ X 'BLOCK) (EDIT_CMDP X))
  401.                                       (PRINT X) )) ))
  402.              *UNDO_LIST* ) )
  403.  
  404. ; EDIT? prints out a user specified number of commands.  Just a simple loop...
  405.  
  406. (DEFUN EDIT?
  407.        NIL
  408.        (PROG (COUNT LIST)
  409.              (COND ((NOT (NUMBERP (SETQ COUNT (EDIT_GET_CMD))))
  410.                     (EDIT_ERROR "EDIT?-bad arg" COUNT)
  411.                     (RETURN NIL) ))
  412.              (SETQ LIST *UNDO_LIST*)
  413.              LOOP
  414.              (COND ((OR (NULL LIST) (ZEROP COUNT))
  415.                     (RETURN NIL) )
  416.                    ((OR (EDIT_CMDP (CAR LIST))
  417.                         (EQ (CAR LIST) 'BLOCK) )
  418.                     (PRINT (CAR LIST))
  419.                     (SETQ COUNT (SUB1 COUNT)) ) )
  420.              (SETQ LIST (CDR LIST))
  421.              (GO LOOP) ) )
  422.  
  423. ; UP is explained in the text.  See the diagram. Note that if the result is
  424. ; a "tail", or sublist, *LAST_TAIL* is set.
  425.  
  426. (DEFUN EDIT_UP
  427.        NIL
  428.        (PROG (CUR_EXP HGHR_EXP)
  429.              (COND ((NULL (SETQ HGHR_EXP (CADR *EDIT_CHAIN*)))
  430.                     (EDIT_ERROR "Already at TOP" NIL) )
  431.                    ((EQ (SETQ CUR_EXP (EDIT_CUR_EXP))
  432.                         (CAR HGHR_EXP) )
  433.                     (SETQ *LAST_TAIL* NIL)
  434.                     (SETQ *EDIT_CHAIN* (CDR *EDIT_CHAIN*)) )
  435.                    ((SETQ *LAST_TAIL* (MEMQ CUR_EXP HGHR_EXP))
  436.                     (SETQ *EDIT_CHAIN*
  437.                           (CONS *LAST_TAIL* (CDR *EDIT_CHAIN*)) ) )
  438.                    ((SETQ *EDIT_CHAIN* (CDR *EDIT_CHAIN*))) ) ) )
  439.  
  440. (DEFUN EDIT_NEXT
  441.        NIL
  442.        (PROG (HGHR_EXP TMP)
  443.              (COND ((NULL (SETQ HGHR_EXP (CADR *EDIT_CHAIN*)))
  444.                     (EDIT_ERROR "No NEXT" NIL) )
  445.                    ((AND (SETQ TMP (MEMQ (EDIT_CUR_EXP) HGHR_EXP))
  446.                          (CONSP (CDR TMP)) )
  447.                     (SETQ *EDIT_CHAIN*
  448.                           (CONS (CADR TMP) (CDR *EDIT_CHAIN*)) ) )
  449.                    (T (EDIT_ERROR "No NEXT" NIL)) ) ) )
  450.  
  451. ; The following 3 predicates are used when searching *UNDO_LIST*.  EDIT_UNDOP,
  452. ; EDIT_SMASHP, and EDIT_CHAINP return "useful" values, i.e. either the
  453. ; undo list element if the predicate is true, or NIL if false.
  454.  
  455. ; If X is an UNDO or UNUNDO command, return X, else NIL.
  456.  
  457. (DEFUN EDIT_UNDOP
  458.        (X)
  459.        (COND ((AND (CONSP X)
  460.                    (MEMQ (CAR X) '(UNDO UNUNDO)) )
  461.               X )) )
  462.  
  463. ; If X is a smash_list, return it, otherwise NIL.
  464.  
  465. (DEFUN EDIT_SMASHP
  466.        (X)
  467.        (COND ((AND (CONSP X) (CONSP (CAR X))) X)
  468.              (T NIL) ) )
  469.  
  470. ; If X is a edit_chain indicator, return it, else NIL.
  471.  
  472. (DEFUN EDIT_CHAINP
  473.        (X)
  474.        (COND ((AND (CONSP X)
  475.                    (EQ (CAR X) '*EDIT_CHAIN*) )
  476.               X )) )
  477.  
  478. ; If X is a command, return T, not X, else NIL.
  479.  
  480. (DEFUN EDIT_CMDP
  481.        (X)
  482.        (AND (CONSP X)
  483.             (ATOM (CAR X))
  484.             (NEQ (CAR X) '*EDIT_CHAIN*) ) )
  485.  
  486. ; EDIT_UNDO undoes the last destructive command that was not an "undo" command,
  487. ; unless a BLOCK intervenes (or there is nothing to undo).  Note that UNDO
  488. ; is undoable by UNUNDO.
  489.  
  490. (DEFUN EDIT_UNDO ()
  491.  (PROG (TMPLIST TMPCAR)
  492.  (SETQ TMPLIST *UNDO_LIST*)
  493.      LOOP
  494.      (COND ((OR (NULL TMPLIST)
  495.                 (EQ (SETQ TMPCAR (CAR TMPLIST))
  496.                     'BLOCK ) )
  497.             (EDIT_ERROR "Nothing to UNDO" NIL) )
  498.            ((AND (EDIT_CMDP TMPCAR)    ; Must be a command
  499.                  (NOT (EDIT_UNDOP TMPCAR)) ) ; but skip "undo" commands.
  500.             (COND ((EDIT_CHAINP (CADR TMPLIST)) ; Verify that *UNDO_LIST* is ok.
  501.                    (EDIT_UNDO1 (CDDR TMPLIST))    ; Undo the previous command.
  502.                    (EDIT_CMD_DONE (LIST 'UNDO))    ; Save the UNDO command.
  503.                    (SETQ *EDIT_CHAIN* (CDADR TMPLIST)) ; Reset *EDIT_CHAIN*.
  504.                    (PRINT (LIST TMPCAR 'UNDONE)) )
  505.                   (T (EDIT_ERROR "EDIT_UNDO-Garbaged *UNDO_LIST*, BIG trouble"
  506.                                  NIL )) ) )
  507.            (T (SETQ TMPLIST (CDR TMPLIST)) (GO LOOP)) ) ) )
  508.  
  509. ; EDIT_UNDO1 actually performs the "undoing", using EDIT_SMASH to allow UNUNDO.
  510.  
  511. (DEFUN EDIT_UNDO1
  512.        (LIST)
  513.        (PROG (TMP)
  514.              LOOP
  515.              (COND ((SETQ TMP (EDIT_SMASHP (CAR LIST)))
  516.                     (EDIT_SMASH (CAR TMP)
  517.                                 (CADR TMP)
  518.                                 (CADDR TMP) )
  519.                     (SETQ LIST (CDR LIST))
  520.                     (GO LOOP) )) ) )
  521.  
  522. ; UNUNDO undoes the last command if and only if it was an UNDO command.
  523.  
  524. (DEFUN EDIT_UNUNDO ()
  525.    (PROG (TMPLIST TMPCAR)
  526.      (COND ((OR (NULL (SETQ TMPLIST *UNDO_LIST*))
  527.                 (EQ (SETQ TMPCAR (CAR TMPLIST)) 
  528.                     'BLOCK ) )
  529.             (EDIT_ERROR "No UNDO to UNDO" NIL) )
  530.            ((EDIT_UNDOP TMPCAR)    ; Is it an "undo" command?
  531.             (COND ((EDIT_CHAINP (CADR TMPLIST))    ; Verify that *UNDO_LIST* is ok.
  532.                    (EDIT_UNDO1 (CDDR TMPLIST))    ; Undo the UNDO.
  533.                    (EDIT_CMD_DONE (LIST 'UNUNDO)) ; Save the UNUNDO command.
  534.                    (SETQ *EDIT_CHAIN* (CDADR TMPLIST)) ; Restore *EDIT_CHAIN*.
  535.                    (PRINT (LIST TMPCAR 'UNDONE)) )
  536.                   (T (EDIT_ERROR "EDIT_UNDO-Garbaged *UNDO_LIST*, BIG trouble"
  537.                                  NIL )) ) )
  538.            (T (EDIT_ERROR "Last command was not UNDO" NIL)) ) ) )
  539.  
  540. ; EDIT_REVERT restores everything that was done since the last TEST/BLOCK was
  541. ; issued.  REVERT is NOT undoable...
  542.  
  543. (DEFUN EDIT_REVERT
  544.        NIL
  545.        (PRINC "Are you SURE?")
  546.        (COND ((MEMQ (READ) '(Y YE YES))
  547.               (PROG (TMPLIST TMPCAR)
  548.                     (SETQ TMPLIST *UNDO_LIST*)
  549.                     LOOP
  550.                     (COND ((OR (NULL TMPLIST)
  551.                                (EQ (SETQ TMPCAR (CAR TMPLIST))
  552.                                    'BLOCK ) )
  553.                            (SETQ *UNDO_LIST* TMPLIST)
  554.                            (RETURN NIL) )
  555.                           ((EDIT_SMASHP TMPCAR)
  556.                            (RPLACA (CAR TMPCAR) (CADR TMPCAR))
  557.                            (RPLACD (CAR TMPCAR) (CADDR TMPCAR)) )
  558.                           ((EDIT_CHAINP TMPCAR)
  559.                            (SETQ *EDIT_CHAIN* (CDR TMPCAR)) ) )
  560.                     (SETQ TMPLIST (CDR TMPLIST))
  561.                     (GO LOOP) ) )) )
  562.  
  563. ; Destructively removes a BLOCK from *UNDO_LIST*
  564.  
  565. (DEFUN EDIT_UNBLOCK
  566.        NIL
  567.        (PROG (TMPLIST)
  568.              (COND ((NULL (SETQ TMPLIST *UNDO_LIST*))    ; Check for nothing on
  569.                     (RETURN NIL) )            ; the list,
  570.                    ((EQ (CAR *UNDO_LIST*) (QUOTE BLOCK)) ; or for BLOCK at the
  571.                     (SETQ *UNDO_LIST* (CDR *UNDO_LIST*)) ) ) ; begining.
  572.              LOOP
  573.              (COND ((EQ (CADR TMPLIST) (QUOTE BLOCK)) ; If BLOCK found,
  574.                     (RPLACD TMPLIST (CDDR TMPLIST))   ; remove it from the list.
  575.                     (RETURN NIL) )
  576.                    ((SETQ TMPLIST (CDR TMPLIST)) (GO LOOP)) ; Keep searching.
  577.                    (T (EDIT_ERROR "No BLOCK found" NIL)) ) ) ) ; Report error.
  578.  
  579.                          
  580. ; The User Interface functions follow.  They are adequately described in the
  581. ; text. If your LISP is "old" and doesn't support DEFMACRO, just change it
  582. ; to a FEXPR and remove the &REST.
  583.  
  584. ; NOTE that getting the function definition varies ridiculously from dialect
  585. ; to dialect.  In NIL, it's
  586. ;
  587. ; (SI:INTERPRETER-CLOSURE-LAMBDA (SYMBOL-FUNCTION FUN))
  588. ;
  589. ; You will have to change this for your LISP.  It shouldn't be as bad as NIL.
  590. ; If there is both a function definition and a saved state, EDITF assumes
  591. ; the saved state is the function.  (It probably should verify this...).
  592.  
  593.  
  594. (DEFMACRO EDITF
  595.           (&REST FUN)
  596.           (SETQ FUN (CAR FUN)) ; Get the function name.
  597.           (PROG (FUNDEF RESULT SAVED_STATE)
  598.                 (COND ((NULL (SETQ FUNDEF (SYMBOL-FUNCTION FUN))) ;*Change this?
  599.                        (PRINT (LIST "No function definition for" FUN))
  600.                        (RETURN NIL) )
  601.                       ((SETQ SAVED_STATE
  602.                              (GET FUN 'EDIT_SAVE) )
  603.                        (SETQ RESULT
  604.                              (EDIT_LIST (CAR SAVED_STATE)
  605.                                         (CADR SAVED_STATE) ) ) )
  606.                       (T (SETQ RESULT
  607.                                (EDIT_LIST (CONS FUNDEF NIL) NIL) )) )
  608.                 (COND ((EQ (CAR RESULT) 'OK)
  609.                        (REMPROP FUN 'EDIT_SAVE)
  610.                        (PUTPROP '*EDIT_LAST* (CDR RESULT) 'EDIT_SAVE)
  611.                        (RETURN (LIST 'QUOTE FUN)) )
  612.                       ((EQ (CAR RESULT) 'SAVE)
  613.                        (PUTPROP FUN (CDR RESULT) 'EDIT_SAVE)
  614.                        (RETURN (LIST 'QUOTE FUN)) )
  615.                       (T (PRINT "Unknown return from EDIT_LIST")
  616.                          NIL ) ) ) )
  617.                          
  618. ; EDITV is roughly the same as EDITF.  Note that in XLISP 1.6 they are the
  619. ; same.  As before, if you have "old" LISP, change to a FEXPR...
  620.  
  621. (DEFMACRO EDITV
  622.           (&REST VAR)
  623.           (SETQ VAR (CAR VAR))
  624.           (PROG (VALUE RESULT SAVED_STATE)
  625.                 (COND ((ATOM (SETQ VALUE (SYMBOL-VALUE VAR)))
  626.                        (PRINT (LIST "Value cannot be edited for" VAR))
  627.                        (RETURN NIL) )
  628.                       ((SETQ SAVED_STATE
  629.                              (GET VAR 'EDIT_SAVE) )
  630.                        (SETQ RESULT
  631.                              (EDIT_LIST (CAR SAVED_STATE)
  632.                                         (CADR SAVED_STATE) ) ) )
  633.                       (T (SETQ RESULT
  634.                                (EDIT_LIST (CONS VALUE NIL) NIL) )) )
  635.                 (COND ((EQ (CAR RESULT) 'OK)
  636.                        (REMPROP VAR 'EDIT_SAVE)
  637.                        (PUTPROP '*EDIT_LAST* (CDR RESULT) 'EDIT_SAVE)
  638.                        (RETURN (LIST 'QUOTE VAR)) )
  639.                       ((EQ (CAR RESULT) 'SAVE)
  640.                        (PUTPROP VAR (CDR RESULT) 'EDIT_SAVE)
  641.                        (RETURN (LIST 'QUOTE VAR)) )
  642.                       (T (PRINT "Unknown return from EDIT_LIST")
  643.                          NIL ) ) ) )
  644.  
  645. (DEFUN EDIT
  646.        (EXPR)
  647.        (PROG (RESULT SAVED_STATE)
  648.              (COND ((NULL EXPR)
  649.                     (COND ((SETQ SAVED_STATE
  650.                                  (GET '*EDIT_LAST* 'EDIT_SAVE) )
  651.                            (SETQ RESULT
  652.                                  (EDIT_LIST (CAR SAVED_STATE)
  653.                                             (CADR SAVED_STATE) ) ) )) )
  654.                    ((CONSP EXPR)
  655.                     (SETQ RESULT
  656.                           (EDIT_LIST (CONS EXPR NIL) NIL) ) )
  657.                    (T (PRINT "Nothing to EDIT") (RETURN NIL)) )
  658.              (PUTPROP '*EDIT_LAST* (CDR RESULT) 'EDIT_SAVE)
  659.              (RETURN (CAR (LAST (CADR RESULT)))) ) )
  660.  
  661. ; This causes everything between the invocation of EDIT_ERROR and the
  662. ; ERRSET in EDIT_LIST1 to be thrown away.
  663.  
  664. (DEFUN EDIT_ERROR
  665.        (STRING ARG)
  666.        (ERROR STRING ARG)
  667.        NIL )
  668.  
  669. ; The I/O functions follow:
  670.  
  671. (DEFUN EDIT_PRINT
  672.        (EXPR DEPTH)
  673.        (COND ((EQ EXPR *LAST_TAIL*) (PRINC "...")))
  674.        (PRINT_LEV EXPR DEPTH) )
  675.  
  676. (DEFUN PRINT_LEV
  677.        (EXPR DEPTH)
  678.        (COND ((ATOM EXPR) (PRIN1 EXPR))
  679.              ((CONSP EXPR)
  680.               (COND ((ZEROP DEPTH) (PRIN1 '&))
  681.                     (T (PRINC "(")
  682.                        (PRINT_LEV1 EXPR DEPTH)
  683.                        (PRINC ")") ) ) ) ) )
  684.  
  685. (DEFUN PRINT_LEV1
  686.        (EXPR DEPTH)
  687.        (PROG (X)
  688.              (SETQ X EXPR)
  689.              LOOP
  690.              (COND ((ATOM (CAR X)) (PRIN1 (CAR X)))
  691.                    (T (PRINT_LEV (CAR X) (- DEPTH 1))) )
  692.              (COND ((NULL (SETQ X (CDR X))) (RETURN))
  693.                    (T (PRINC " ") (GO LOOP)) ) ) )
  694.  
  695. ; Just a simple READ protected by an ERRSET to prevent accidental exits
  696. ; from the editor or a user induced break.
  697.  
  698. (DEFUN EDIT_GET_CMD
  699.        NIL
  700.        (PROG (X)
  701.              LOOP
  702.              (COND ((SETQ X (ERRSET (READ) NIL))
  703.                     (RETURN (CAR X)) )
  704.                    (T (PRINC "*") (GO LOOP)) ) ) )
  705.  
  706. (DEFUN EDIT_GET_ARG NIL (READ))
  707.