(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL)) READTABLE "XCL" BASE 10)

(IL:FILECREATED "15-Aug-2021 21:22:22" 
IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;7|
 125181 

      IL:|changes| IL:|to:|  (IL:VARS IL:SEDIT-COMMANDSCOMS)

      IL:|previous| IL:|date:| "14-Aug-2021 12:59:29" 
IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)


; Copyright (c) 1986-1988, 1990-1991, 2018, 2021 by Venue & Xerox Corporation.

(IL:PRETTYCOMPRINT IL:SEDIT-COMMANDSCOMS)

(IL:RPAQQ IL:SEDIT-COMMANDSCOMS

          ((IL:PROP IL:FILETYPE IL:SEDIT-COMMANDS)
           (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-COMMANDS)
           (IL:LOCALVARS . T)
           (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS))
           (IL:VARIABLES COMMAND-TABLE-SPEC *EDIT-FN* *WRAP-SEARCH*)
           (IL:VARS MENU-DESCRIPTION (FIND-CANDIDATE NIL)
                  (SUBSTITUTE-CANDIDATE NIL)
                  (MUTATE-CANDIDATE NIL)
                  (PACKAGE-CANDIDATE NIL)
                  (PRINTBASE-CANDIDATE NIL))
           (IL:INITVARS (CONVERT-UPGRADE 100)
                  (WANT-MENU NIL)
                  (MENUS NIL))
           (IL:CONSTANTS (WORD-DELIM-CHARS (IL:CHARCODE (IL:SPACE IL:CR IL:TAB - IL:{ IL:} IL:[ IL:]
                                                               IL:\; < > IL:\.))))
           (IL:FUNCTIONS 

                  (IL:* IL:|;;| "pseudo-selections")


                  PSEUDO-SELECTION-FROM-SELECTION COMPOSE-PSEUDO-SELECTION DECOMPOSE-PSEUDO-SELECTION
                  SELECTION-FROM-PSEUDO-SELECTION SELECT-PSEUDO-SEGMENT)
           
           (IL:* IL:|;;| "user interface to adding new commands")


           (IL:FUNCTIONS ADD-COMMAND GET-SELECTION REPLACE-SELECTION RESET-COMMANDS DEFAULT-COMMANDS)
           (IL:VARIABLES DEFAULT-COMMAND-TABLE-SPEC FIRST-ADD-COMMAND FIRST-ADD-COMMAND-MENU-ENTRY)
           (IL:FUNCTIONS 

                  (IL:* IL:|;;| "building help menu")


                  EQUALIZE-STRING-WIDTHS MINIMUM-STRING-WIDTH MAXIMUM-STRING-WIDTH)
           (IL:FUNCTIONS FIND-AND-DISPLAY-STRUCTURE FIND-AND-DISPLAY-STRUCTURE-BACKWARDS 
                  FIND-AND-DISPLAY-SUBSTRUCTURE FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS 
                  FIND-NTH-STRUCTURE FIND-NODE-SUBSTRUCTURE FIND-NODE-SUBSTRUCTURE-BACKWARDS FIND-OBJ
                  FIND-SELECTION FIND-SELECTION-BACKWARDS FIND-STRUCTURE FIND-STRUCTURE-BACKWARDS 
                  FIND-SUBSTRUCTURE FIND-SUBSTRUCTURE-BACKWARDS GET-USER-STRING SEARCH-OBJ 
                  SEARCH-OBJ-BACKWARDS SUBSTITUTE-OBJ SUBSTITUTE-STRUCTURE SUBSTITUTE-SUBSTRUCTURE 
                  STRUCTURE-FROM-SELECTION STRUCTURE-FROM-STRING COMMENT-OUT-SELECTION)
           (IL:FNS ADD-MENU BACKSPACE CHANGE-PACKAGE CHANGE-PRINTBASE CHANGE-QUOTE CONVERT-COMMENT 
                  CONVERT-COMMENT-STRUCTURE CONVERT-COMMENT-TAIL CREATE-COMMAND-TABLE DEFAULT-EDIT-FN
                  DELETE-SELECTION DELETE-WORD DO-MUTATION EDIT-SELECTION EVAL-SELECTION EXPAND 
                  EXTRACT-CURRENT-SELECTION FIND-COMMENT GET-MENU EDIT-HELP HELPMENU INPUT-DOT 
                  INPUT-ESCAPE INPUT-NORMAL-CHAR INPUT-QUOTE INPUT-SQUARE-BRACKET INPUT-STRINGDELIM 
                  INPUT-TOKENDELIM INSERT-MULTI-ESCAPE INSERT-SPECIAL-CHARACTER INSPECT-SELECTION 
                  JOIN MENU-CLOSEFN MENU-FIND-SELECTEDFN MENU-INIT-STATE MENU-PACKAGE-SELECTEDFN 
                  MENU-PRINTBASE-SELECTEDFN MENU-SELECTEDFN MENU-SUBSTITUTE-SELECTEDFN MUTATE 
                  QUOTE-CURRENT-SELECTION REDISPLAY REDO SELECTED-FN-NAME SKIP-TO-GAP UNDO 
                  UNDO-EXTRACT)))

(IL:PUTPROPS IL:SEDIT-COMMANDS
 IL:FILETYPE
 :COMPILE-FILE)

(IL:PUTPROPS IL:SEDIT-COMMANDS
 IL:MAKEFILE-ENVIRONMENT
 (:READTABLE "XCL" :PACKAGE
                                                                      (DEFPACKAGE IL:SEDIT
                                                                             (:USE IL:LISP IL:XCL))))
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY

(IL:LOCALVARS . T)
)
(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 

(IL:FILESLOAD IL:SEDIT-DECLS)
)

(DEFPARAMETER COMMAND-TABLE-SPEC


(IL:* IL:|;;;| "each entry in the COMMAND-TABLE-SPEC should be of the form: (<fn> <help menu entry> <normalize?> <key>+) where <fn> is an atom function name or a list whose car is the function name and the rest are the extra arguments (beyond context and charcode), <help menu entry> is a list of strings for the name, key-name, and help-string, <normalize?> is T if the caret should be normalized after this command, and <key>+ is one or more key specifier which can be passed to charcode (if non-list) or whose car is a termtable syntax (if a list).")


   '(
     (IL:* IL:|;;| "STRUCTURE CONTROL")


     (INSERT-NULL-LIST NIL T (IL:LEFTPAREN))
     (CLOSE-LIST NIL NIL (IL:RIGHTPAREN))
     (INPUT-SQUARE-BRACKET
 NIL NIL (IL:LEFTBRACKET)
            (IL:RIGHTBRACKET))
     (INPUT-TOKENDELIM
 NIL T (IL:SEPRCHAR))
     (INPUT-STRINGDELIM
 NIL NIL (IL:STRINGDELIM))
     (INPUT-ESCAPE
 NIL NIL (IL:ESCAPE))
     (INSERT-MULTI-ESCAPE
 NIL NIL (IL:MULTIPLE-ESCAPE))
     (INSERT-SPECIAL-CHARACTER
 NIL NIL (IL:PACKAGEDELIM))
     (START-COMMENT NIL NIL ";")
     (INPUT-DOT
 NIL NIL ".")
     (INSERT-SPECIAL-CHARACTER
 NIL NIL "#")
     ((INPUT-QUOTE
 QUOTE)
      NIL NIL "'")
     ((INPUT-QUOTE
 IL:BQUOTE)
      NIL NIL "`")
     ((INPUT-QUOTE
 IL:COMMA)
      NIL NIL ",")
     ((INPUT-QUOTE
 COMMA-AT)
      NIL NIL "@")

     (IL:* IL:|;;| "EDIT CONTROL")


     (DELETE-SELECTION
 NIL T IL:DEL)
     (BACKSPACE
 NIL T IL:BS "^A")
     (DELETE-WORD
 NIL T "^W")
     ((VERIFY-STRUCTURE NIL T T)
      NIL NIL "^L")
     ((VERIFY-STRUCTURE NIL T NIL)
      NIL NIL "Meta,^L")

     (IL:* IL:|;;| "COMPLETION")


     ((COMPLETE :ABORT NIL)
      ("Abort" "M-A" "Complete this edit without installing changes.")
      NIL "Meta,A" "Meta,a" (ABORT))
     (NULL ("" "" "")
           NIL 0)
     ((COMPLETE :DONE NIL)
      ("Done" "C-X" "Complete this edit and leave the window open.")
      NIL "^X" (DONE))
     ((COMPLETE :CLOSE)
      ("Done & Close" "C-M-X" "Complete this edit and close the window.")
      NIL "Meta,^X" (EXIT))
     ((COMPLETE :DONE T)
      ("Done & Compile" "C-C" "Complete this edit, compile, and leave the window open.")
      NIL "^C" (COMPILE))
     ((COMPLETE :CLOSE T)
      ("Done, Compile, & Close" "C-M-C" "Complete this edit, compile, and close the window.")
      NIL "Meta,^C")

     (IL:* IL:|;;| "COMMANDS")


     (NULL ("" "" "")
           NIL 0)
     (UNDO
 ("Undo" "M-U" "Undo the last change made.")
            NIL "Meta,U" "Meta,u" "Function,^D" (UNDO
))
     (REDO
 ("Redo" "M-R" "Redo the last change undone.")
            NIL "Meta,R" "Meta,r" "Function,Bs" (REDO
))
     (NULL ("" "" "")
           NIL 0)
     (FIND-OBJ
 ("Find" "M-F" "Find the current selection, or prompt for structure to Find.")
            T "Meta,F" "Meta,f" "Function,^C" (FIND))
     ((FIND-OBJ
 NIL T)
      ("Reverse Find" "C-M-F" "Find the current selection, or prompt for structure to Find.")
      T "Meta,^F")
     ((SUBSTITUTE-OBJ
 NIL NIL T)
      ("Remove" "C-M-S" "Remove structures from within the current selection.")
      NIL "Meta,^S")
     (SUBSTITUTE-OBJ
 ("Substitute" "M-S" "Substitute structures within the current selection.")
            NIL "Meta,S" "Meta,s" "Function,#" (SUBSTITUTE))
     (SKIP-TO-GAP
 ("Find Gap" "M-N" "Skip to the next fill in gap.")
            T "Meta,N" "Meta,n" "Function,^R")
     (NULL ("" "" "")
           NIL 0)
     (EDIT-HELP
 ("Arglist" "M-H" "Show the argument list for the selected function.")
            NIL "Meta,H" "Meta,h" "Function,^A" (ARGLIST))
     (CONVERT-COMMENT
 ("Convert Comment" "M-;" 
                                 "Convert the old style comments in the current selection.")
            NIL "Meta,;")
     (COMMENT-OUT-SELECTION
 NIL NIL "Meta,^;")
     (EDIT-SELECTION
 ("Edit" "M-O" "Edit the definition of the current selection.")
            NIL "Meta,O" "Meta,o" (EDIT))
     ((EDIT-SELECTION
 (:CURRENT))
      ("Edit Fast" "C-M-O" "Edit the current definition of the selection.")
      NIL "Meta,^O")
     (EVAL-SELECTION
 ("Eval" "M-E" "Evaluate the current selection.")
            NIL "Meta,E" "Meta,e" (EVAL))
     (EXPAND
 ("Expand" "M-X" "Replace the current selection with its definition.")
            NIL "Meta,X" "Meta,x" IL:ESC "Function,^T" (EXPAND
))
     (EXTRACT-CURRENT-SELECTION
 ("Extract" "M-/" 
                                           "Extract one level of structure: unquote or unlist.")
            NIL "Meta,/" (EXTRACT))
     (INSPECT-SELECTION
 ("Inspect" "M-I" "Inspect the current selection.")
            NIL "Meta,I" "Meta,i" (INSPECT))
     (JOIN
 ("Join" "M-J" "Join selected items together.")
            NIL "Meta,J" "Meta,j" (JOIN
))
     (MUTATE
 ("Mutate" "M-Z" "Prompt for a function to operate on the current selection.")
            NIL "Meta,Z" "Meta,z")
     ((PARENTHESIZE-CURRENT-SELECTION NIL)
      ("Parenthesize" "M-(" "Parenthesize the current selection.")
      NIL "Meta,(" "Meta,71" (PAREN))
     ((PARENTHESIZE-CURRENT-SELECTION T)
      NIL NIL "Meta,)" "Meta,60")
     ((QUOTE-CURRENT-SELECTION
 QUOTE)
      ("Quote" "M-'" "Quote the current selection.")
      NIL "Meta,'" (QUOTE))
     ((QUOTE-CURRENT-SELECTION
 IL:BQUOTE)
      NIL NIL "Meta,`")
     ((QUOTE-CURRENT-SELECTION
 IL:COMMA)
      NIL NIL "Meta,,")
     ((QUOTE-CURRENT-SELECTION
 COMMA-AT)
      NIL NIL "Meta,@" "Meta,62")
     ((QUOTE-CURRENT-SELECTION
 COMMA-DOT)
      NIL NIL "Meta,.")
     ((QUOTE-CURRENT-SELECTION
 FUNCTION)
      NIL NIL "Meta,#" "Meta,63")
     (NULL ("" "" "")
           NIL 0)
     (CHANGE-PRINTBASE
 ("Set Print-Base" "M-B" "Set the print-base for this edit.")
            NIL "Meta,B" "Meta,b" (SET-PRINT-BASE))
     (CHANGE-PACKAGE
 ("Set Package" "M-P" "Set the package to edit in.")
            NIL "Meta,P" "Meta,p" (SET-PACKAGE))
     (ADD-MENU
 ("Attach Menu" "M-M" "Attach a command menu.")
            NIL "Meta,M" "Meta,m")

     (IL:* IL:|;;| "RANDOM: tells Meta-Space or Meta-Return to scroll to the selection, using the auto-scroller for free.")


     (TRUE NIL T "Meta, " "Meta,CR")))

(DEFPARAMETER *EDIT-FN*
 'DEFAULT-EDIT-FN)

(DEFVAR *WRAP-SEARCH*
 NIL)

(IL:RPAQQ MENU-DESCRIPTION

          ((IL:PROPS IL:FONT (IL:HELVETICA 10 IL:BOLD))
           ((IL:GROUP (IL:PROPS IL:FORMAT IL:COLUMN IL:COLUMNSPACE 20 IL:ROWSPACE 3)
                   ((IL:GROUP (IL:PROPS IL:FORMAT IL:TABLE IL:COLUMNSPACE 12)
                           ((IL:PROPS IL:BOX 1)
                            (IL:LABEL EXIT IL:SELECTEDFN MENU-SELECTEDFN)
                            (IL:LABEL DONE IL:SELECTEDFN MENU-SELECTEDFN)
                            (IL:LABEL ABORT IL:SELECTEDFN MENU-SELECTEDFN IL:MAXWIDTH 39))
                           ((IL:PROPS IL:BOX 1)
                            (IL:LABEL UNDO IL:SELECTEDFN MENU-SELECTEDFN)
                            (IL:LABEL REDO IL:SELECTEDFN MENU-SELECTEDFN)
                            (IL:LABEL ARGLIST IL:SELECTEDFN MENU-SELECTEDFN))))
                   ((IL:GROUP (IL:PROPS IL:FORMAT IL:TABLE IL:COLUMNSPACE 12)
                           ((IL:PROPS IL:BOX 1)
                            (IL:LABEL PAREN IL:SELECTEDFN MENU-SELECTEDFN)
                            (IL:LABEL QUOTE IL:SELECTEDFN MENU-SELECTEDFN)
                            (IL:LABEL EXTRACT IL:SELECTEDFN MENU-SELECTEDFN))
                           ((IL:PROPS IL:BOX 1)
                            (IL:LABEL EDIT IL:SELECTEDFN MENU-SELECTEDFN)
                            (IL:LABEL EVAL IL:SELECTEDFN MENU-SELECTEDFN)
                            (IL:LABEL EXPAND IL:SELECTEDFN MENU-SELECTEDFN IL:MAXWIDTH 46))))))
           ((IL:LABEL PRINT-BASE IL:SELECTEDFN MENU-PRINTBASE-SELECTEDFN IL:ID PRINTBASE-ITEM 
                   IL:LINKS (IL:EDIT PRINTBASE-VALUE-ITEM))
            (IL:LABEL "" TYPE IL:NUMBER IL:MAXWIDTH 14 IL:ID PRINTBASE-VALUE-ITEM IL:FONT
                   (IL:GACHA 10))
            (IL:LABEL PACKAGE IL:SELECTEDFN MENU-PACKAGE-SELECTEDFN IL:ID PACKAGE-ITEM IL:LINKS
                   (IL:EDIT PACKAGE-NAME-ITEM))
            (IL:LABEL "" TYPE IL:EDIT IL:ID PACKAGE-NAME-ITEM IL:FONT (IL:GACHA 10)))
           ((IL:GROUP (IL:PROPS IL:FORMAT IL:TABLE)
                   ((IL:LABEL FIND\: IL:SELECTEDFN MENU-FIND-SELECTEDFN IL:LINKS (IL:EDIT FINDITEM))
                    (IL:LABEL "" TYPE IL:EDIT IL:ID FINDITEM IL:FONT (IL:GACHA 10)))
                   ((IL:LABEL SUBSTITUTE\: IL:SELECTEDFN MENU-SUBSTITUTE-SELECTEDFN IL:LINKS
                           (IL:EDIT SUBSTITUTEITEM FINDITEM FINDITEM))
                    (IL:LABEL "" TYPE IL:EDIT IL:ID SUBSTITUTEITEM IL:FONT (IL:GACHA 10)))))))

(IL:RPAQQ FIND-CANDIDATE
 NIL)

(IL:RPAQQ SUBSTITUTE-CANDIDATE
 NIL)

(IL:RPAQQ MUTATE-CANDIDATE
 NIL)

(IL:RPAQQ PACKAGE-CANDIDATE
 NIL)

(IL:RPAQQ PRINTBASE-CANDIDATE
 NIL)

(IL:RPAQ? CONVERT-UPGRADE
 100)

(IL:RPAQ? WANT-MENU
 NIL)

(IL:RPAQ? MENUS
 NIL)
(IL:DECLARE\: IL:EVAL@COMPILE 

(IL:RPAQ WORD-DELIM-CHARS
 (IL:CHARCODE (IL:SPACE IL:CR IL:TAB - IL:{ IL:} IL:[ IL:] IL:\; < > 
                                                  IL:\.)))


(IL:CONSTANTS (WORD-DELIM-CHARS (IL:CHARCODE (IL:SPACE IL:CR IL:TAB -
 IL:{ IL:} IL:[ IL:] IL:\; <
                                                    > IL:\.))))
)

(DEFUN PSEUDO-SELECTION-FROM-SELECTION
 (SEL)

(IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers.  It's interpreted as the select-node, select-start, and select-end fields of a selection.")


(IL:* IL:|;;;| "This function takes a selection and creates a pseudo selection from it.")


   (COMPOSE-PSEUDO-SELECTION
 (IL:FETCH
 SELECT-NODE IL:OF
 SEL)
          (IL:FETCH
 SELECT-START IL:OF
 SEL)
          (OR (IL:FETCH
 SELECT-END IL:OF
 SEL)
              (IL:FETCH
 SELECT-START IL:OF
 SEL))))

(DEFUN COMPOSE-PSEUDO-SELECTION
 (NODE &OPTIONAL START END)

(IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers.  It's interpreted as the select-node, select-start, and select-end fields of a selection.")


(IL:* IL:|;;;| "This function takes the fields of a pseudo selection and hands back one.")


   (COND
      ((LISTP NODE)
       (LIST (IL:FETCH
 SUPER-NODE IL:OF
 (FIRST NODE))
             (+ (IL:FETCH
 SUB-NODE-INDEX IL:OF
 (FIRST NODE))
                (OR START 0))
             (+ (IL:FETCH
 SUB-NODE-INDEX IL:OF
 (FIRST NODE))
                (1- (OR END (LENGTH NODE))))))
      ((OR START END)
       (LIST NODE (OR START END)
             (OR END START)))
      (T NODE)))

(DEFUN DECOMPOSE-PSEUDO-SELECTION
 (PSEL)

(IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers.  It's interpreted as the select-node, select-start, and select-end fields of a selection.")


(IL:* IL:|;;;| "This function takes a pseudo selection and hands its fields back as values.")


   (IF (LISTP PSEL)
       (VALUES (FIRST PSEL)
              (OR (SECOND PSEL)
                  (THIRD PSEL))
              (OR (THIRD PSEL)
                  (SECOND PSEL)))
       (VALUES PSEL NIL NIL)))

(DEFUN SELECTION-FROM-PSEUDO-SELECTION
 (PSEL &OPTIONAL SEL)

(IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers.  It's interpreted as the select-node, select-start, and select-end fields of a selection.")


(IL:* IL:|;;;| "This function takes a pseudo-selection and constructs the corresponding selection.  If you don't hand it a selection structure, it conses one.")


   (UNLESS SEL
       (SETF SEL (IL:CREATE
 EDIT-SELECTION)))
   (MULTIPLE-VALUE-BIND (NODE START END)
          (DECOMPOSE-PSEUDO-SELECTION
 PSEL)
          (IL:REPLACE
 SELECT-NODE IL:OF
 SEL IL:WITH
 NODE)
          (IL:REPLACE
 SELECT-START IL:OF
 SEL IL:WITH
 START)
          (IL:REPLACE
 SELECT-END IL:OF
 SEL IL:WITH
 END)
          SEL))

(DEFUN SELECT-PSEUDO-SEGMENT
 (CONTEXT PSEL &OPTIONAL SET-POINT? WHERE)
   (MULTIPLE-VALUE-BIND (NODE START END)
          (DECOMPOSE-PSEUDO-SELECTION
 PSEL)
          (IF START
              (SELECT-NODE-SEGMENT CONTEXT NODE START END)
              (SELECT-NODE CONTEXT NODE SET-POINT? WHERE))))



(IL:* IL:|;;| "user interface to adding new commands")



(DEFUN ADD-COMMAND
 (KEY-CODE FORM &OPTIONAL SCROLL? KEY-NAME COMMAND-NAME HELP-STRING)
   (WHEN FIRST-ADD-COMMAND

       (IL:* IL:|;;| "cache the command-table-spec so the user can undo this!")


       (SETQ DEFAULT-COMMAND-TABLE-SPEC (COPY-TREE COMMAND-TABLE-SPEC))
       (SETQ FIRST-ADD-COMMAND NIL))
   (WHEN (AND KEY-NAME COMMAND-NAME FIRST-ADD-COMMAND-MENU-ENTRY)

       (IL:* IL:|;;| "add another separation line to the help menu.")


       (NCONC COMMAND-TABLE-SPEC (LIST (LIST 'NULL (LIST "-----" "" "")
                                             NIL 0)))
       (SETQ FIRST-ADD-COMMAND-MENU-ENTRY NIL))
   (NCONC COMMAND-TABLE-SPEC (LIST (LIST FORM (WHEN (AND KEY-NAME COMMAND-NAME)
                                                    (LIST KEY-NAME COMMAND-NAME HELP-STRING))
                                         SCROLL? KEY-CODE)))
   (OR COMMAND-NAME FORM))

(DEFUN GET-SELECTION
 (CONTEXT)
               (IL:* IL:\; "Edited 23-Apr-2018 18:11 by rmk:")


                                                     (IL:* IL:\; "Edited 22-Apr-2018 16:48 by rmk:")

   (LET* ((SELECTION (IL:FETCH
 SELECTION IL:OF
 CONTEXT))
          (NODE (IL:FETCH
 SELECT-NODE IL:OF
 SELECTION))
          (CHARS (IL:FETCH
 STRUCTURE IL:OF
 NODE))
          (START (IL:FETCH
 SELECT-START IL:OF
 SELECTION))
          (END (IL:FETCH
 SELECT-END IL:OF
 SELECTION))
          (STRING (IL:FETCH
 SELECT-STRING IL:OF
 SELECTION))
          (TYPE (IL:FETCH
 SELECT-TYPE IL:OF
 SELECTION))
          NOT-ALL-SELECTED)

         (IL:* IL:|;;| "All except NODE are needed for the atom/string cases")


         (COND
            ((NULL NODE)
             (VALUES NIL NIL))
            ((EQ TYPE 'STRUCTURE)
             (VALUES (STRUCTURE-FROM-SELECTION
 SELECTION)
                    (COND
                       (START :SUB-LIST)
                       (T T))))
            (T 
               (IL:* IL:|;;| "RMK: a single character-atom or a substring of characters in an atom or string. Full multicharacter atoms are structures.  Code copies from COPY-SELECTION-LITATOM")


               (WHEN (IL:TYPE?
 BROKEN-ATOM CHARS)
                   (IL:SETQ CHARS (IL:FETCH
 ATOM-CHARS IL:OF
 CHARS)))
               (WHEN (AND START (OR (IL:NEQ (OR END (IL:SETQ END START))
                                           (IL:NCHARS STRING))
                                    (IL:NEQ START 1)))

                   (IL:* IL:|;;| "some subset of the atom/string has been selected")


                   (IL:SETQ NOT-ALL-SELECTED T))
               (VALUES (IL:MKSTRING (IF NOT-ALL-SELECTED
                                        (DETRANSLATE-CHARS (IL:SUBSTRING STRING START END)
                                               TYPE)
                                        CHARS)
                              (IF (EQ TYPE 'STRING)
                                  (NULL START)
                                  (NOT NOT-ALL-SELECTED)))
                      :CHARACTERS)))))

(DEFUN REPLACE-SELECTION
 (CONTEXT STRUCTURE SELECTION-TYPE)
   (UNLESS (OR (EQ SELECTION-TYPE T)
               (EQ SELECTION-TYPE :SUB-LIST))
          (ERROR "Illegal SELECTION-TYPE arg: ~A." SELECTION-TYPE))
   (LET* ((SELECTION (IL:FETCH
 SELECTION IL:OF
 CONTEXT))
          (POINT (IL:|fetch|
 CARET-POINT IL:|of|
 CONTEXT))
          NEW-NODES)
         (COND
            ((OR (NOT (IL:FETCH
 SELECT-NODE IL:OF
 SELECTION))
                 (NOT (EQ (IL:FETCH
 SELECT-TYPE IL:OF
 SELECTION)
                          'STRUCTURE)))
             (ERROR "Invalid SEdit selection.  Can't REPLACE-SELECTION."))
            ((EQ SELECTION-TYPE :SUB-LIST)
             (SETQ NEW-NODES (MAPCAR #'(LAMBDA (S)
                                              (PARSE-NEW S CONTEXT))
                                    STRUCTURE)))
            (T (SETQ NEW-NODES (PARSE-NEW STRUCTURE CONTEXT))))
         (PENDING-DELETE POINT SELECTION)
         (INSERT POINT CONTEXT (COPY-LIST NEW-NODES))

         (IL:* IL:|;;| "try to select the stuff that was just inserted.")


         (SELECT-PSEUDO-SEGMENT
 CONTEXT (COMPOSE-PSEUDO-SELECTION
 NEW-NODES))))

(DEFUN RESET-COMMANDS
 ()
   (LET ((COMMANDS (CREATE-COMMAND-TABLE
 COMMAND-TABLE-SPEC)))
        (IL:REPLACE
 (EDIT-ENV COMMAND-TABLE) IL:OF
 LISP-EDIT-ENVIRONMENT IL:WITH

                                                                                 (FIRST COMMANDS))
        (IL:REPLACE
 (EDIT-ENV HELP-MENU) IL:OF
 LISP-EDIT-ENVIRONMENT IL:WITH
 (SECOND
                                                                                          COMMANDS)))
   T)

(DEFUN DEFAULT-COMMANDS
 ()
   (SETQ COMMAND-TABLE-SPEC (COPY-TREE DEFAULT-COMMAND-TABLE-SPEC))
   (SETQ FIRST-ADD-COMMAND-MENU-ENTRY T)
   (RESET-COMMANDS
)
   T)

(DEFGLOBALVAR DEFAULT-COMMAND-TABLE-SPEC
 NIL
   "Used to cache the original command table spec for Reset-Commands")

(DEFGLOBALVAR FIRST-ADD-COMMAND
 T
   "Used in Add-Command to know if this is the first new command for help-menu update purposes")

(DEFGLOBALVAR FIRST-ADD-COMMAND-MENU-ENTRY
 T
   "Used in Add-Command to signal the first time a new command is added to the middle button menu, so that the user entries can be separated from the default entries"
)

(DEFUN EQUALIZE-STRING-WIDTHS
 (STRING-LIST FONT &OPTIONAL PRIN2? (DESIRED-WIDTH (

                                                                               MAXIMUM-STRING-WIDTH

                                                                                     STRING-LIST FONT
                                                                                     PRIN2?))
                                         (PAD-CHAR #\Space))

(IL:* IL:|;;;| "Increase the width of all the strings in STRING-LIST to DESIRED-WIDTH by padding them on the right with PAD-CHAR.")


   (DO ((PAD-CHAR-WIDTH (IL:CHARWIDTH (CHAR-CODE PAD-CHAR)
                               FONT))
        (STR STRING-LIST (REST STR)))
       ((NULL STR)
        STRING-LIST)
     (SETF (FIRST STR)
           (CONCATENATE 'STRING (FIRST STR)
                  (MAKE-STRING (CEILING (- DESIRED-WIDTH (IL:STRINGWIDTH (FIRST STR)
                                                                FONT PRIN2?))
                                      PAD-CHAR-WIDTH)
                         :INITIAL-ELEMENT PAD-CHAR)))))

(DEFUN MINIMUM-STRING-WIDTH
 (STRING-LIST FONT PRIN2?)
   (APPLY #'MIN (MAPCAR #'(LAMBDA (S)
                                 (IL:STRINGWIDTH S FONT PRIN2?))
                       STRING-LIST)))

(DEFUN MAXIMUM-STRING-WIDTH
 (STRING-LIST FONT PRIN2?)
   (APPLY #'MAX (MAPCAR #'(LAMBDA (S)
                                 (IL:STRINGWIDTH S FONT PRIN2?))
                       STRING-LIST)))

(DEFUN FIND-AND-DISPLAY-STRUCTURE
 (CONTEXT STR &OPTIONAL SCOPE START WRAP?)

(IL:* IL:|;;;| "Find structure and display it by selecting it (point after) and normalizing the selection in the window.  SCOPE defaults to the root structure of the CONTEXT.  The WRAP? flag says to wrap failing searches around and try them again (i.e., ignore start and try again).")


   (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
          (TOP (SUBNODE 1 (IL:FETCH
 ROOT IL:OF
 CONTEXT)))
          (TARGET (FIND-STRUCTURE
 STR (OR SCOPE TOP)
                         START)))
         (COND
            (TARGET (SELECT-NODE CONTEXT TARGET T T)
                   (FORMAT PROMPTWINDOW "~%~S - Found." STR))
            ((AND WRAP? START)
             (FIND-AND-DISPLAY-STRUCTURE
 CONTEXT STR SCOPE))
            (T (FORMAT PROMPTWINDOW "~%~S - Not found." STR)))))

(DEFUN FIND-AND-DISPLAY-STRUCTURE-BACKWARDS
 (CONTEXT STR &OPTIONAL SCOPE END WRAP?)

(IL:* IL:|;;;| "Like find-and-display-structure, but searches backwards")


   (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
          (TOP (SUBNODE 1 (IL:FETCH
 ROOT IL:OF
 CONTEXT)))
          (TARGET (FIND-STRUCTURE-BACKWARDS
 STR (OR SCOPE TOP)
                         END)))
         (COND
            (TARGET (SELECT-NODE CONTEXT TARGET T T)
                   (FORMAT PROMPTWINDOW "~%~S - Found." STR))
            ((AND WRAP? END)
             (FIND-AND-DISPLAY-STRUCTURE-BACKWARDS
 CONTEXT STR SCOPE))
            (T (FORMAT PROMPTWINDOW "~%~S - Not found." STR)))))

(DEFUN FIND-AND-DISPLAY-SUBSTRUCTURE
 (CONTEXT STR &OPTIONAL SCOPE START WRAP?)

(IL:* IL:|;;;| "Find substructure and display it by selecting it (pending delete) and normalizing the selection in the window.  SCOPE defaults to the root structure of the CONTEXT.  The WRAP? flag says to wrap failing searches around and try them again (i.e., ignore start and try again).")


   (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
          (TOP (SUBNODE 1 (IL:FETCH
 ROOT IL:OF
 CONTEXT)))
          (TARGET (FIND-SUBSTRUCTURE
 STR (OR SCOPE TOP)
                         START)))
         (COND
            (TARGET (SELECT-PSEUDO-SEGMENT
 CONTEXT TARGET)
                   (FORMAT PROMPTWINDOW "~%~{~S ~}- Found." STR))
            ((AND WRAP? START)
             (FIND-AND-DISPLAY-SUBSTRUCTURE
 CONTEXT STR SCOPE))
            (T (FORMAT PROMPTWINDOW "~%~{~S ~}- Not found." STR)))))

(DEFUN FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS
 (CONTEXT STR &OPTIONAL SCOPE END WRAP?)

(IL:* IL:|;;;| "Like find-and-display-substructure but searches backwards")


   (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
          (TOP (SUBNODE 1 (IL:FETCH
 ROOT IL:OF
 CONTEXT)))
          (TARGET (FIND-SUBSTRUCTURE-BACKWARDS
 STR (OR SCOPE TOP)
                         END)))
         (COND
            (TARGET (SELECT-PSEUDO-SEGMENT
 CONTEXT TARGET)
                   (FORMAT PROMPTWINDOW "~%~{~S ~}- Found." STR))
            ((AND WRAP? END)
             (FIND-AND-DISPLAY-SUBSTRUCTURE
 CONTEXT STR SCOPE))
            (T (FORMAT PROMPTWINDOW "~%~{~S ~}- Not found." STR)))))

(DEFUN FIND-NTH-STRUCTURE
 (CONTEXT CHARCODE STRUCTURE N)

(IL:* IL:|;;;| "Find the Nth occurance of Structure in this edit, always starting from the beginning.  This function is used as an external command to set the selection to a desired structure.  Find, select, and normalize.")


   (LET ((TOP (SUBNODE 1 (IL:FETCH
 ROOT IL:OF
 CONTEXT))))
        (DO ((M 1 (+ M 1))
             (TARGET (FIND-STRUCTURE
 STRUCTURE TOP)
                    (FIND-STRUCTURE
 STRUCTURE TOP (NEXT-NODE TARGET))))
            ((OR (NULL TARGET)
                 (= N M))
             (AND TARGET (SELECT-NODE CONTEXT TARGET T T)))))
   T)

(DEFUN FIND-NODE-SUBSTRUCTURE
 (STR STRLEN NODE &OPTIONAL START END CONTINUATION?)

(IL:* IL:|;;;| "STR is a list of structures of length STRLEN.  NODE, together with START and END (which are subnode indices), is taken to indicate a subtree.  We return a pseudo-selection which selects the first sequence of sibling nodes in that subtree whose successive structures match the successive elements of STR.")


(IL:* IL:|;;;| "\"First\" here is taken to mean \"first in linearization order\", so we have to do a careful recursion which: (1a) recursively checks the subtree rooted at the START subnode of NODE (default the first), (1b) checks if the START subnode starts a matching sibling sequence, (2a) recursively checks the subtree rooted at the START+1 subnode of NODE,  (2b) checks if the START+1 subnode starts a matching sibling sequence, . . ., (Na) recusively checks the subtree rooted at the END subnode of NODE (default the last), (Nb) checks if the END subnode starts a matching sibling sequence [note that such a sequence could be only 1 node long since END is the right end of the subtree being checked].")


(IL:* IL:|;;;| "N.B. It might seem that, to get true linearization order, we should check to see if a node starts a matching sibling sequence before we check its subtree.  But since node structures can not be circular, we know that if a match is found in the subtree  below a node then that node could not have started a matching sequence.")


(IL:* IL:|;;;| "The CONTINUATION? flag means that we are continuing a search that has already recursively checked the START subnode, so we skip that particular recursion.  This generally happens when we are working our way up and to the right in some subtree which has already been partially checked.")


   (SETF START (OR START 1))
   (LET* ((SUBNODES (IL:FETCH
 SUB-NODES IL:OF
 NODE))
          (LASTINDEX (OR END (FIRST SUBNODES))))
         (DO ((SUBS (NTHCDR START SUBNODES)
                    (REST SUBS))
              (INDEX START (1+ INDEX))
              (ENDINDEX (+ START (1- STRLEN))
                     (1+ ENDINDEX))
              (DOSUBS? (NOT CONTINUATION?)
                     T)
              MATCH)
             ((OR (NULL SUBS)
                  (AND END (> INDEX END)))
              NIL)
           (WHEN (AND DOSUBS? (SETF MATCH (FIND-NODE-SUBSTRUCTURE
 STR STRLEN (FIRST SUBS))))
                 (RETURN MATCH))
           (UNLESS (OR (> ENDINDEX LASTINDEX)
                       (MISMATCH STR SUBS :END2 STRLEN :TEST
                              #'(LAMBDA (S N)
                                       (IL:EQUAL S (IL:FETCH
 STRUCTURE IL:OF
 N)))))
               (RETURN (LIST NODE INDEX ENDINDEX))))))

(DEFUN FIND-NODE-SUBSTRUCTURE-BACKWARDS
 (STR STRLEN NODE &OPTIONAL START END CONTINUATION?)

(IL:* IL:|;;;| "Like find-node-substructure but searches in reverse linearization order.")


   (LET* ((SUBNODES (IL:FETCH
 SUB-NODES IL:OF
 NODE))
          (SUBLENGTH (FIRST SUBNODES)))
         (SETF END (OR END SUBLENGTH))
         (DO ((SUBS (NTHCDR (- SUBLENGTH END)
                           (REVERSE (CDR SUBNODES)))
                    (CDR SUBS))
              (INDEX END (1- INDEX))
              (STARTINDEX (- END (1- STRLEN))
                     (1- STARTINDEX))
              (DOSUBS? (NOT CONTINUATION?)
                     T)
              MATCH)
             ((OR (NULL SUBS)
                  (AND START (< INDEX START)))
              NIL)
           (WHEN (AND DOSUBS? (SETF MATCH (FIND-NODE-SUBSTRUCTURE-BACKWARDS
 STR STRLEN
                                                 (FIRST SUBS))))
                 (RETURN MATCH))
           (UNLESS (OR (< STARTINDEX 1)
                       (MISMATCH STR SUBS :END2 STRLEN :TEST
                              #'(LAMBDA (S N)
                                       (IL:EQUAL S (IL:FETCH
 STRUCTURE IL:OF
 N)))))
               (RETURN (LIST NODE STARTINDEX INDEX))))))

(DEFUN FIND-OBJ
 (CONTEXT &OPTIONAL CHARCODE FIND-STRING BACKWARDS?)

(IL:* IL:|;;;| "Find either the passed structure, the selected structure, or a prompted-for structure.  The search direction is forward unless BACKWARDS? is specified.")


   (CLOSE-OPEN-NODE CONTEXT)
   (LET ((SELECTION (IL:|fetch|
 SELECTION IL:|of|
 CONTEXT))
         (WRAP? *WRAP-SEARCH*))
        (COND
           ((AND (NULL FIND-STRING)
                 (IL:|fetch|
 SELECT-NODE IL:|of|
 SELECTION)
                 (EQ (IL:|fetch|
 SELECT-TYPE IL:|of|
 SELECTION)
                     'STRUCTURE))

            (IL:* IL:|;;| "there is a non-string selection")


            (IF BACKWARDS?
                (FIND-SELECTION-BACKWARDS
 CONTEXT WRAP?)
                (FIND-SELECTION
 CONTEXT WRAP?)))
           (T (IF BACKWARDS?
                  (SEARCH-OBJ-BACKWARDS
 CONTEXT FIND-STRING WRAP?)
                  (SEARCH-OBJ
 CONTEXT FIND-STRING WRAP?)))))
   T)

(DEFUN FIND-SELECTION
 (CONTEXT &OPTIONAL WRAP?)

(IL:* IL:|;;;| "Find the next match of the current selection and display it.")


   (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
          (SELECTION (IL:|fetch|
 SELECTION IL:|of|
 CONTEXT))
          (NODE (IL:|fetch|
 SELECT-NODE IL:|of|
 SELECTION))
          (START (IL:|fetch|
 SELECT-START IL:|of|
 SELECTION)))
         (IF START

             (IL:* IL:|;;| "a sibling sequence is selected, look for a matching sequence after it")


             (FIND-AND-DISPLAY-SUBSTRUCTURE
 CONTEXT (STRUCTURE-FROM-SELECTION
 SELECTION)
                    NIL
                    (LIST NODE (1+ START))
                    WRAP?)

             (IL:* IL:|;;| "a node is selected, look for a matching node ")


             (IF (SETF START (NEXT-NODE NODE T))

                 (IL:* IL:|;;| "start the search with the following node")


                 (FIND-AND-DISPLAY-STRUCTURE
 CONTEXT (STRUCTURE-FROM-SELECTION
 SELECTION)
                        NIL START WRAP?)

                 (IL:* IL:|;;| "there are no more nodes, either wrap or give up")


                 (IF WRAP?
                     (FIND-AND-DISPLAY-STRUCTURE
 CONTEXT (STRUCTURE-FROM-SELECTION
 SELECTION)
                            )
                     (FORMAT PROMPTWINDOW "~%At end; no more structure to search."))))))

(DEFUN FIND-SELECTION-BACKWARDS
 (CONTEXT &OPTIONAL WRAP?)

(IL:* IL:|;;;| "Find the previous match of the current selection and display it.")


   (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
          (SELECTION (IL:|fetch|
 SELECTION IL:|of|
 CONTEXT))
          (NODE (IL:|fetch|
 SELECT-NODE IL:|of|
 SELECTION))
          (END (OR (IL:|fetch|
 SELECT-START IL:|of|
 SELECTION)
                   (IL:|fetch|
 SELECT-END IL:|of|
 SELECTION))))
         (IF END

             (IL:* IL:|;;| "a sibling sequence is selected, look for a matching sequence before it")


             (FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS
 CONTEXT (STRUCTURE-FROM-SELECTION

                                                                   SELECTION)
                    NIL
                    (LIST NODE (1- END))
                    WRAP?)

             (IL:* IL:|;;| "a node is selected, look for a matching node ")


             (IF (SETF END (PREV-NODE NODE T))

                 (IL:* IL:|;;| "start the search with the previous node")


                 (FIND-AND-DISPLAY-STRUCTURE-BACKWARDS
 CONTEXT (STRUCTURE-FROM-SELECTION

                                                                    SELECTION)
                        NIL END WRAP?)

                 (IL:* IL:|;;| "there are no more nodes, either wrap or give up")


                 (IF WRAP?
                     (FIND-AND-DISPLAY-STRUCTURE-BACKWARDS
 CONTEXT (STRUCTURE-FROM-SELECTION

                                                                        SELECTION))
                     (FORMAT PROMPTWINDOW "~%At beginning; no more structure to search."))))))

(DEFUN FIND-STRUCTURE
 (STR SCOPE &OPTIONAL START)

(IL:* IL:|;;;| "Search forward in linearization order for a node whose structure matches STR.  The search is bounded by SCOPE (a pseudo-selection taken to indicate a subtree) and starts at START (a pseudo-selection taken to indicate its left-most node).  START defaults to SCOPE.    The return value is the first node in SCOPE at or after START whose structure is IL:EQUAL to STR.")


(IL:* IL:|;;;| "N.B. Since node structures can not be circular, no subnode of a node can have structure matching that node.  Thus looking for a matching node in pre-order is the same as looking for one in linearization order.  So we do a pre-order search here.")


   (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END)
          (DECOMPOSE-PSEUDO-SELECTION
 SCOPE)
          (MULTIPLE-VALUE-BIND (START-NODE START-START)
                 (DECOMPOSE-PSEUDO-SELECTION
 START)
                 (WHEN (AND (NULL SCOPE-START)
                            (OR (NULL START-NODE)
                                (AND (NULL START-START)
                                     (EQ START-NODE SCOPE-NODE)))
                            (IL:EQUAL STR (IL:FETCH
 STRUCTURE IL:OF
 SCOPE-NODE)))

                     (IL:* IL:|;;| "special case: the scope includes its root node, we're starting at the root of the scope, and the root of the scope matches the passed structure.")


                     (RETURN-FROM FIND-STRUCTURE SCOPE-NODE))

                 (IL:* IL:|;;| "normal case: check all the nodes in the scope subtree in preorder.")


                 (DO* ((MIN-DEPTH (1+ (IL:FETCH
 DEPTH IL:OF
 SCOPE-NODE)))
                       (NODE (OR (IF START-START
                                     (SUBNODE START-START START-NODE)
                                     (UNLESS (EQ START-NODE SCOPE-NODE)
                                            START-NODE))
                                 (IF SCOPE-START
                                     (SUBNODE SCOPE-START SCOPE-NODE)
                                     (NEXT-NODE SCOPE-NODE)))
                             (NEXT-NODE NODE)))
                      ((OR (NULL NODE)
                           (< (IL:FETCH
 DEPTH IL:OF
 NODE)
                              MIN-DEPTH)
                           (AND SCOPE-END (EQ (IL:FETCH
 SUPER-NODE IL:OF
 NODE)
                                              SCOPE-NODE)
                                (> (IL:FETCH
 SUB-NODE-INDEX IL:OF
 NODE)
                                   SCOPE-END)))
                       NIL)
                    (WHEN (IL:EQUAL STR (IL:FETCH
 STRUCTURE IL:OF
 NODE))
                          (RETURN NODE))))))

(DEFUN FIND-STRUCTURE-BACKWARDS
 (STR SCOPE &OPTIONAL END)

(IL:* IL:|;;;| "like find-structure but searches in reverse linearization order.  Actually we search in postorder rather than reverse linearization order but this works just as well for the same reasons that preorder matches linearization order.")


   (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END)
          (DECOMPOSE-PSEUDO-SELECTION
 SCOPE)
          (MULTIPLE-VALUE-BIND (END-NODE END-START END-END)
                 (DECOMPOSE-PSEUDO-SELECTION
 END)
                 (WHEN (AND (NULL SCOPE-START)
                            (OR (NULL END-NODE)
                                (AND (NULL END-START)
                                     (EQ END-NODE SCOPE-NODE)))
                            (IL:EQUAL STR (IL:FETCH
 STRUCTURE IL:OF
 SCOPE-NODE)))

                     (IL:* IL:|;;| "special case: the scope includes its root node, we're ending at the root of the scope, and the root of the scope matches the passed structure.")


                     (RETURN-FROM FIND-STRUCTURE-BACKWARDS SCOPE-NODE))

                 (IL:* IL:|;;| 

               "normal case: check all the nodes in the scope subtree in postorder.")


                 (DO* ((MIN-DEPTH (1+ (IL:FETCH
 DEPTH IL:OF
 SCOPE-NODE)))
                       (NODE (OR (IF END-END
                                     (SUBNODE END-END END-NODE)
                                     (UNLESS (EQ END-NODE SCOPE-NODE)
                                            END-NODE))
                                 (IF SCOPE-END
                                     (SUBNODE SCOPE-END SCOPE-NODE)
                                     (PREV-NODE SCOPE-NODE)))
                             (PREV-NODE NODE)))
                      ((OR (NULL NODE)
                           (< (IL:FETCH
 DEPTH IL:OF
 NODE)
                              MIN-DEPTH)
                           (AND SCOPE-START (EQ (IL:FETCH
 SUPER-NODE IL:OF
 NODE)
                                                SCOPE-NODE)
                                (< (IL:FETCH
 SUB-NODE-INDEX IL:OF
 NODE)
                                   SCOPE-START)))
                       NIL)
                    (WHEN (IL:EQUAL STR (IL:FETCH
 STRUCTURE IL:OF
 NODE))
                          (RETURN NODE))))))

(DEFUN FIND-SUBSTRUCTURE
 (STR SCOPE &OPTIONAL START)

(IL:* IL:|;;;| "Search forward in linearization order for a sequence of nodes whose successive structures match the successive elements of STR.  The search is bounded by SCOPE (a pseudo-selection taken to indicate a subtree) and starts at START (a pseudo-selection taken to indicate the left edge of a subtree).  START defauts to SCOPE.  The return value is a pseudo-selection indicating the sibling sequence of nodes in SCOPE at or to the right of START whose successive node structures are IL:EQUAL to the successive members of STR.")


(IL:* IL:|;;;| "N.B. For a sequence of sibling nodes, first in linearization order can not be found by doing a preorder search.  See find-node-substructure for details about the correct search method.")


   (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END)
          (DECOMPOSE-PSEUDO-SELECTION
 SCOPE)
          (MULTIPLE-VALUE-BIND (START-NODE START-START)
                 (DECOMPOSE-PSEUDO-SELECTION
 START)
                 (COND
                    ((NULL START-NODE)

                     (IL:* IL:|;;| "just check the entire scope")


                     (FIND-NODE-SUBSTRUCTURE
 STR (LENGTH STR)
                            SCOPE-NODE SCOPE-START SCOPE-END))
                    ((EQ START-NODE SCOPE-NODE)

                     (IL:* IL:|;;| "just check a terminal subtree of the scope")


                     (FIND-NODE-SUBSTRUCTURE
 STR (LENGTH STR)
                            SCOPE-NODE START-START SCOPE-END))
                    (T 
                       (IL:* IL:|;;| "check each node from the start subtree up and to the right in the scope subtree.  We carefully resume the recursion that would have happened if we had started from the root of the subtree.  This means checking remaining structure in super-nodes on our way from the start node back up the subtree.")


                       (DO ((NODE START-NODE SUPER-NODE)
                            (SUPER-NODE (IL:FETCH
 SUPER-NODE IL:OF
 START-NODE)
                                   (IL:FETCH
 SUPER-NODE IL:OF
 NODE))
                            (NODE-INDEX (IL:FETCH
 SUB-NODE-INDEX IL:OF
 START-NODE)
                                   (IL:FETCH
 SUB-NODE-INDEX IL:OF
 NODE))
                            (CONTINUATION? NIL T)
                            (START START-START NODE-INDEX)
                            (END NIL (AND (EQ NODE SCOPE-NODE)
                                          SCOPE-END))
                            (STRLEN (LENGTH STR))
                            MATCH)
                           ((OR (NULL NODE)
                                (SETF MATCH (FIND-NODE-SUBSTRUCTURE
 STR STRLEN NODE START END 
                                                   CONTINUATION?))
                                (EQ NODE SCOPE-NODE))
                            MATCH)))))))

(DEFUN FIND-SUBSTRUCTURE-BACKWARDS
 (STR SCOPE &OPTIONAL END)

(IL:* IL:|;;;| "Like find-substructure but searches in reverse linearization order.")


   (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END)
          (DECOMPOSE-PSEUDO-SELECTION
 SCOPE)
          (MULTIPLE-VALUE-BIND (END-NODE END-START END-END)
                 (DECOMPOSE-PSEUDO-SELECTION
 END)
                 (COND
                    ((NULL END-NODE)

                     (IL:* IL:|;;| "just check the entire scope")


                     (FIND-NODE-SUBSTRUCTURE-BACKWARDS
 STR (LENGTH STR)
                            SCOPE-NODE SCOPE-START SCOPE-END))
                    ((EQ END-NODE SCOPE-NODE)

                     (IL:* IL:|;;| "just check an initial subtree of the scope")


                     (FIND-NODE-SUBSTRUCTURE-BACKWARDS
 STR (LENGTH STR)
                            SCOPE-NODE SCOPE-START END-END))
                    (T 
                       (IL:* IL:|;;| "check each node in the initial subtree of scope terminated by the end subtree.  We carefully resume the recursion that would have happened if we had started from the root of the scope subtree.  This means checking remaining structure in super-nodes on our way from the end node back up the subtree.")


                       (DO ((NODE END-NODE SUPER-NODE)
                            (SUPER-NODE (IL:FETCH
 SUPER-NODE IL:OF
 END-NODE)
                                   (IL:FETCH
 SUPER-NODE IL:OF
 NODE))
                            (NODE-INDEX (IL:FETCH
 SUB-NODE-INDEX IL:OF
 END-NODE)
                                   (IL:FETCH
 SUB-NODE-INDEX IL:OF
 NODE))
                            (CONTINUATION? NIL T)
                            (END END-END NODE-INDEX)
                            (START NIL (AND (EQ NODE SCOPE-NODE)
                                            SCOPE-START))
                            (STRLEN (LENGTH STR))
                            MATCH)
                           ((OR (NULL NODE)
                                (SETF MATCH (FIND-NODE-SUBSTRUCTURE-BACKWARDS
 STR STRLEN NODE 
                                                   START END CONTINUATION?))
                                (EQ NODE SCOPE-NODE))
                            MATCH)))))))

(DEFUN GET-USER-STRING
 (CONTEXT PROMPT DEFAULT)
   (LET ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)))
        (IL:TERPRI PROMPTWINDOW)
        (IL:TTYINPROMPTFORWORD PROMPT DEFAULT NIL PROMPTWINDOW NIL NIL (IL:CHARCODE (IL:CR ^X)))))

(DEFUN SEARCH-OBJ
 (CONTEXT &OPTIONAL SEARCH-STRING WRAP?)

(IL:* IL:|;;;| "Search for the the structure(s) in the string SEARCH-OBJ and display them.  The search starts just after the current point  or selection, if any.")


   (MULTIPLE-VALUE-BIND (STR STRLEN)
          (STRUCTURE-FROM-STRING
 (OR SEARCH-STRING (SETF SEARCH-STRING
                                                             (GET-USER-STRING
 CONTEXT "Find: "
                                                                    (OR (IL:|fetch|
 
                                                                               FIND-CANDIDATE
                                                                           IL:|of|
 CONTEXT)
                                                                        FIND-CANDIDATE)))))
          (COND
             ((< STRLEN 0)
              (FORMAT (GET-PROMPT-WINDOW CONTEXT)
                     " -- Invalid structure.")
              (RETURN-FROM SEARCH-OBJ))
             ((= STRLEN 0)
              (FORMAT (GET-PROMPT-WINDOW CONTEXT)
                     "-- aborted.")
              (RETURN-FROM SEARCH-OBJ)))

          (IL:* IL:|;;| "update the remembered defaults")


          (IL:|replace|
 FIND-CANDIDATE IL:|of|
 CONTEXT IL:|with|
 (IL:SETQ FIND-CANDIDATE
                                                                              SEARCH-STRING))

          (IL:* IL:|;;| "figure out where to search and where to start")


          (LET* ((SCOPE (SUBNODE 1 (IL:FETCH
 ROOT IL:OF
 CONTEXT)))
                 (START (LET* ((POINT (IL:|fetch|
 CARET-POINT IL:|of|
 CONTEXT))
                               (POINT-TYPE (IL:|fetch|
 POINT-TYPE IL:|of|
 POINT))
                               (POINT-NODE (IL:|fetch|
 POINT-NODE IL:|of|
 POINT))
                               (POINT-INDEX (IL:|fetch|
 POINT-INDEX IL:|of|
 POINT))
                               (SELECTION (IL:|fetch|
 SELECTION IL:|of|
 CONTEXT))
                               (SELECT-TYPE (IL:FETCH
 SELECT-TYPE IL:OF
 SELECTION))
                               (SELECT-NODE (IL:|fetch|
 SELECT-NODE IL:|of|
 SELECTION))
                               (SELECT-START (IL:|fetch|
 SELECT-START IL:|of|
 SELECTION)))
                              (COND
                                 ((TYPEP POINT-NODE 'EDIT-NODE)
                                  (IF (EQ POINT-TYPE 'STRUCTURE)
                                      (NEXT-NODE POINT-NODE POINT-INDEX)
                                      (NEXT-NODE POINT-NODE T)))
                                 ((TYPEP SELECT-NODE 'EDIT-NODE)
                                  (IF (AND (EQ SELECT-TYPE 'STRUCTURE)
                                           SELECT-START)
                                      (LIST SELECT-NODE (1+ SELECT-START))
                                      (NEXT-NODE SELECT-NODE T)))
                                 (T SCOPE)))))
                (UNLESS (OR WRAP? START)

                    (IL:* IL:|;;| "Nothing left to search, and we're not supposed to wrap")


                    (FORMAT (GET-PROMPT-WINDOW CONTEXT)
                           "~%At end; no more structure to search.")
                    (RETURN-FROM SEARCH-OBJ))

                (IL:* IL:|;;| "do the search")


                (IF (> STRLEN 1)

                    (IL:* IL:|;;| "substructure search")


                    (FIND-AND-DISPLAY-SUBSTRUCTURE
 CONTEXT STR SCOPE START WRAP?)

                    (IL:* IL:|;;| "structure search")


                    (FIND-AND-DISPLAY-STRUCTURE
 CONTEXT (FIRST STR)
                           SCOPE START WRAP?)))))

(DEFUN SEARCH-OBJ-BACKWARDS
 (CONTEXT &OPTIONAL SEARCH-STRING WRAP?)

(IL:* IL:|;;;| "Like search-obj but searches backwards.")


   (MULTIPLE-VALUE-BIND (STR STRLEN)
          (STRUCTURE-FROM-STRING
 (OR SEARCH-STRING (SETF SEARCH-STRING
                                                             (GET-USER-STRING
 CONTEXT "Find: "
                                                                    (OR (IL:|fetch|
 
                                                                               FIND-CANDIDATE
                                                                           IL:|of|
 CONTEXT)
                                                                        FIND-CANDIDATE)))))
          (COND
             ((< STRLEN 0)
              (FORMAT (GET-PROMPT-WINDOW CONTEXT)
                     " -- Invalid structure.")
              (RETURN-FROM SEARCH-OBJ-BACKWARDS))
             ((= STRLEN 0)
              (FORMAT (GET-PROMPT-WINDOW CONTEXT)
                     "-- aborted.")
              (RETURN-FROM SEARCH-OBJ-BACKWARDS)))

          (IL:* IL:|;;| "update the remembered defaults")


          (IL:|replace|
 FIND-CANDIDATE IL:|of|
 CONTEXT IL:|with|
 (IL:SETQ FIND-CANDIDATE
                                                                              SEARCH-STRING))

          (IL:* IL:|;;| "figure out where to search and where to start")


          (LET* ((SCOPE (SUBNODE 1 (IL:FETCH
 ROOT IL:OF
 CONTEXT)))
                 (END (LET* ((POINT (IL:|fetch|
 CARET-POINT IL:|of|
 CONTEXT))
                             (POINT-TYPE (IL:|fetch|
 POINT-TYPE IL:|of|
 POINT))
                             (POINT-NODE (IL:|fetch|
 POINT-NODE IL:|of|
 POINT))
                             (POINT-INDEX (IL:|fetch|
 POINT-INDEX IL:|of|
 POINT))
                             (SELECTION (IL:|fetch|
 SELECTION IL:|of|
 CONTEXT))
                             (SELECT-TYPE (IL:FETCH
 SELECT-TYPE IL:OF
 SELECTION))
                             (SELECT-NODE (IL:|fetch|
 SELECT-NODE IL:|of|
 SELECTION))
                             (SELECT-END (OR (IL:|fetch|
 SELECT-END IL:|of|
 SELECTION)
                                             (IL:|fetch|
 SELECT-START IL:|of|
 SELECTION))))
                            (COND
                               ((TYPEP POINT-NODE 'EDIT-NODE)
                                (IF (EQ POINT-TYPE 'STRUCTURE)
                                    (PREV-NODE POINT-NODE (1+ POINT-INDEX))
                                    (PREV-NODE POINT-NODE T)))
                               ((TYPEP SELECT-NODE 'EDIT-NODE)
                                (IF (EQ SELECT-TYPE 'STRUCTURE)
                                    (LIST SELECT-NODE (1- SELECT-END))
                                    (PREV-NODE SELECT-NODE T)))
                               (T SCOPE)))))
                (UNLESS (OR WRAP? END)

                    (IL:* IL:|;;| "Nothing left to search, and we're not supposed to wrap")


                    (FORMAT (GET-PROMPT-WINDOW CONTEXT)
                           "~%At beginning; no more structure to search.")
                    (RETURN-FROM SEARCH-OBJ-BACKWARDS))

                (IL:* IL:|;;| "do the search")


                (IF (> STRLEN 1)

                    (IL:* IL:|;;| "substructure search")


                    (FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS
 CONTEXT STR SCOPE END WRAP?)

                    (IL:* IL:|;;| "structure search")


                    (FIND-AND-DISPLAY-STRUCTURE-BACKWARDS
 CONTEXT (FIRST STR)
                           SCOPE END WRAP?)))))

(DEFUN SUBSTITUTE-OBJ
 (CONTEXT &OPTIONAL CHARCODE OLDSTR NEWSTR REMOVE?)

(IL:* IL:|;;;| "OLDSTR and NEWSTR are strings.  In the scope of the selection, replace every occurence of structure matching OLDSTR by structure parsed from NEWSTR.  If REMOVE? is specified, just remove structure matching OLD.")


(IL:* IL:|;;;| "We preserve the selection as best we can.  Point gets thrown away.")


   (CLOSE-OPEN-NODE CONTEXT)
   (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
          (SELECTION (IL:|fetch|
 SELECTION IL:|of|
 CONTEXT))
          (SCOPE NIL)
          (TYPE (IF REMOVE?
                    "delet"
                    "substitut")))                           (IL:* IL:\; "hack!!!")

         (UNLESS (AND (IL:|fetch|
 SELECT-NODE IL:|of|
 SELECTION)
                      (EQ (IL:|fetch|
 SELECT-TYPE IL:|of|
 SELECTION)
                          'STRUCTURE))
             (FORMAT PROMPTWINDOW "~%Please select a structure to ~Ae within." TYPE)
             (RETURN-FROM SUBSTITUTE-OBJ T))
         (SETQ SCOPE (PSEUDO-SELECTION-FROM-SELECTION
 SELECTION))
         (MULTIPLE-VALUE-BIND (OLD OLDLEN)
                (STRUCTURE-FROM-STRING
 (OR OLDSTR (SETF OLDSTR
                                                            (GET-USER-STRING
 CONTEXT
                                                                   (IF REMOVE?
                                                                       "Delete form: "
                                                                       "Replace old form: ")
                                                                   (OR (IL:|fetch|
 FIND-CANDIDATE
                                                                          IL:|of|
 CONTEXT)
                                                                       FIND-CANDIDATE)))))
                (COND
                   ((< OLDLEN 0)
                    (FORMAT PROMPTWINDOW " -- Invalid structure.")
                    (RETURN-FROM SUBSTITUTE-OBJ T))
                   ((= OLDLEN 0)
                    (FORMAT PROMPTWINDOW "-- aborted.")
                    (RETURN-FROM SUBSTITUTE-OBJ T)))
                (MULTIPLE-VALUE-BIND (NEW NEWLEN)
                       (IF REMOVE?
                           (VALUES NIL 0)
                           (STRUCTURE-FROM-STRING
 (OR NEWSTR
                                                          (SETF NEWSTR
                                                                (GET-USER-STRING

                                                                 CONTEXT "with new form: "
                                                                 (OR (IL:|fetch|
 
                                                                            SUBSTITUTE-CANDIDATE
                                                                        IL:|of|
 CONTEXT)
                                                                     SUBSTITUTE-CANDIDATE))))))
                       (COND
                          ((< NEWLEN 0)
                           (FORMAT PROMPTWINDOW " -- Invalid structure.")
                           (RETURN-FROM SUBSTITUTE-OBJ T))
                          ((AND (NOT REMOVE?)
                                (= NEWLEN 0))
                           (FORMAT PROMPTWINDOW "-- aborted.")
                           (RETURN-FROM SUBSTITUTE-OBJ T)))

                       (IL:* IL:|;;| "update defaults ")


                       (IL:|replace|
 FIND-CANDIDATE IL:|of|
 CONTEXT IL:|with|
 (IL:SETQ 
                                                                                       FIND-CANDIDATE
                                                                                           OLDSTR))
                       (UNLESS REMOVE?
                           (IL:|replace|
 SUBSTITUTE-CANDIDATE IL:|of|
 CONTEXT
                              IL:|with|
 (IL:SETQ SUBSTITUTE-CANDIDATE NEWSTR)))

                       (IL:* IL:|;;| "do the substitution, report, and reselect.")


                       (MULTIPLE-VALUE-BIND (NEW-SCOPE SUBCOUNT)
                              (IF (> OLDLEN 1)
                                  (SUBSTITUTE-SUBSTRUCTURE
 CONTEXT OLD NEW SCOPE REMOVE?)
                                  (SUBSTITUTE-STRUCTURE
 CONTEXT (FIRST OLD)
                                         NEW SCOPE REMOVE?))
                              (CASE SUBCOUNT
                                  (0 (FORMAT PROMPTWINDOW "~%No ~Aions made." TYPE))
                                  (1 (FORMAT PROMPTWINDOW "~%1 ~Aion made." TYPE))
                                  (OTHERWISE (FORMAT PROMPTWINDOW "~%~A ~Aions made." SUBCOUNT TYPE)))
                              (WHEN NEW-SCOPE (SELECT-PSEUDO-SEGMENT
 CONTEXT NEW-SCOPE))))))
   T)

(DEFUN SUBSTITUTE-STRUCTURE
 (CONTEXT OLD NEW SCOPE &OPTIONAL REMOVE?)

(IL:* IL:|;;;| "Inside SCOPE, replace any node with structure OLD by nodes gotten from parsing NEW.  If REMOVE? is given, just delete the old nodes.  Returns two values: the final scope after all substitutions are made, and the number of substitutions/deletions made.")


(IL:* IL:|;;;| "The substitution is done as a single undoable operation, and the current selection and point are thrown away.")


   (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END)
          (DECOMPOSE-PSEUDO-SELECTION
 SCOPE)
          (LET* ((ROOT (IL:FETCH
 ROOT IL:OF
 CONTEXT))(IL:* IL:\; 

                                                           "substituting for root is special")

                 (POINT (IL:FETCH
 CARET-POINT IL:OF
 CONTEXT))
                 (SELECTION (IL:FETCH
 SELECTION IL:OF
 CONTEXT))
                 (NEWLEN (IF REMOVE?
                             0
                             (LENGTH NEW)))
                 (DELTA-LENGTH (- NEWLEN 1)))
                (START-UNDO-BLOCK)
                (DO* ((TARGET (FIND-STRUCTURE
 OLD SCOPE)
                             (AND RESUME (FIND-STRUCTURE
 OLD SCOPE RESUME)))
                      (TARGET-SUPER (AND TARGET (IL:FETCH
 SUPER-NODE IL:OF
 TARGET))
                             (AND TARGET (IL:FETCH
 SUPER-NODE IL:OF
 TARGET)))
                      (TARGET-INDEX (AND TARGET (IL:FETCH
 SUB-NODE-INDEX IL:OF
 TARGET))
                             (AND TARGET (IL:FETCH
 SUB-NODE-INDEX IL:OF
 TARGET)))
                      (RESUME (AND TARGET (NEXT-NODE TARGET T))
                             (AND TARGET (NEXT-NODE TARGET T)))
                      (NEW-NODES (AND TARGET (NOT REMOVE?)
                                      (MAPCAR #'(LAMBDA (S)
                                                       (PARSE-NEW S CONTEXT))
                                             NEW))
                             (AND TARGET (NOT REMOVE?)
                                  (MAPCAR #'(LAMBDA (N)
                                                   (COPY-NODE N CONTEXT))
                                         NEW-NODES)))
                      (NUMSUBS 0 (1+ NUMSUBS)))
                     ((NULL TARGET)
                      (END-UNDO-BLOCK)
                      (SET-POINT-NOWHERE POINT)
                      (SET-SELECTION-NOWHERE SELECTION)
                      (VALUES SCOPE NUMSUBS))

                   (IL:* IL:|;;| "replace the target ")


                   (SELECT-NODE CONTEXT TARGET)
                   (COND
                      (REMOVE? (COND
                                  ((EQ TARGET-SUPER ROOT)

                                   (IL:* IL:|;;| "\"delete\" the root structure by making it nil")


                                   (PENDING-DELETE POINT SELECTION)
                                   (INSERT-NULL-LIST CONTEXT))
                                  (T (DELETE-SELECTION
 CONTEXT))))
                      (T (PENDING-DELETE POINT SELECTION)
                         (INSERT POINT CONTEXT (COPY-LIST NEW-NODES))))

                   (IL:* IL:|;;| "fix up the scope, if necessary")


                   (COND
                      ((EQ TARGET SCOPE-NODE)

                       (IL:* IL:|;;| "matched the scope, so we're done")


                       (COND
                          (REMOVE? (SETF SCOPE NIL))
                          ((= NEWLEN 1)
                           (SETF SCOPE (SUBNODE TARGET-INDEX TARGET-SUPER)))
                          (T 
                             (IL:* IL:|;;| "replacing the root structure with multiple nodes inserts a new level of list between the root (target-super) and the multiple nodes inserted.  In this case, make the scope node be the new list node instead of the root itself.")


                             (SETF SCOPE (LIST (IF (EQ TARGET-SUPER ROOT)
                                                   (SUBNODE 1 ROOT)
                                                   TARGET-SUPER)
                                               TARGET-INDEX
                                               (+ TARGET-INDEX (1- NEWLEN))))))
                       (SETF RESUME NIL))
                      ((AND SCOPE-START (EQ TARGET-SUPER SCOPE-NODE))

                       (IL:* IL:|;;| "matched a direct subnode of an extended scope")


                       (WHEN (= TARGET-INDEX SCOPE-END)
                             (SETF RESUME NIL))
                       (SETF (THIRD SCOPE)
                             (INCF SCOPE-END DELTA-LENGTH))))))))

(DEFUN SUBSTITUTE-SUBSTRUCTURE
 (CONTEXT OLD NEW SCOPE &OPTIONAL REMOVE?)

(IL:* IL:|;;;| "Inside SCOPE, replace any sequences of nodes whose structures sequentially match the elements of OLD by nodes gotten from parsing NEW.  If REMOVE? is given, just delete the old sequences.  Returns two values: the final scope after all substitutions are made, and the number of substitutions/deletions made.")


(IL:* IL:|;;;| "The substitution is done as a single undoable operation, and the current selection and point are thrown away.")


   (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END)
          (DECOMPOSE-PSEUDO-SELECTION
 SCOPE)
          (LET* ((POINT (IL:|fetch|
 CARET-POINT IL:|of|
 CONTEXT))
                 (SELECTION (IL:|fetch|
 SELECTION IL:|of|
 CONTEXT))
                 (NEWLEN (IF REMOVE?
                             0
                             (LENGTH NEW)))
                 (DELTA-LENGTH (- NEWLEN (LENGTH OLD))))
                (START-UNDO-BLOCK)
                (DO* ((TARGET (FIND-SUBSTRUCTURE
 OLD SCOPE)
                             (AND RESUME (FIND-SUBSTRUCTURE
 OLD SCOPE RESUME)))
                      (NEW-NODES (AND TARGET (NOT REMOVE?)
                                      (MAPCAR #'(LAMBDA (S)
                                                       (PARSE-NEW S CONTEXT))
                                             NEW))
                             (AND TARGET (NOT REMOVE?)
                                  (MAPCAR #'(LAMBDA (N)
                                                   (COPY-NODE N CONTEXT))
                                         NEW-NODES)))
                      (NUMSUBS 0 (1+ NUMSUBS))
                      RESUME)
                     ((NULL TARGET)
                      (END-UNDO-BLOCK)
                      (SET-POINT-NOWHERE POINT)
                      (SET-SELECTION-NOWHERE SELECTION)
                      (VALUES SCOPE NUMSUBS))
                   (MULTIPLE-VALUE-BIND (TNODE TSTART TEND)
                          (DECOMPOSE-PSEUDO-SELECTION
 TARGET)

                          (IL:* IL:|;;| "replace the target ")


                          (SELECT-PSEUDO-SEGMENT
 CONTEXT TARGET)
                          (COND
                             (REMOVE? (DELETE-SELECTION
 CONTEXT))
                             (T (PENDING-DELETE POINT SELECTION)
                                (INSERT POINT CONTEXT (COPY-LIST NEW-NODES))))

                          (IL:* IL:|;;| 

                        "fix up the scope, if necessary, and figure where to resume")


                          (COND
                             ((AND SCOPE-START (EQ TNODE SCOPE-NODE))

                              (IL:* IL:|;;| "matched direct subnodes of an extended scope")


                              (IF (= TEND SCOPE-END)
                                  (SETF RESUME NIL)
                                  (SETF RESUME (LIST TNODE (+ TEND 1 DELTA-LENGTH))))
                              (SETF (THIRD SCOPE)
                                    (INCF SCOPE-END DELTA-LENGTH)))
                             (T (SETF RESUME (LIST TNODE (+ TEND 1))))))))))

(DEFUN STRUCTURE-FROM-SELECTION
 (SELECTION)

(IL:* IL:|;;;| "selection must be a structure selection.  Return the structure encompassed by selection, which if the selection is a node is the structure of that node, and if the selection is a segment a list of the structures of the nodes in that segment.")


   (LET* ((NODE (IL:FETCH
 SELECT-NODE IL:OF
 SELECTION))
          (START (IL:FETCH
 SELECT-START IL:OF
 SELECTION))
          (END (OR (IL:FETCH
 SELECT-END IL:OF
 SELECTION)
                   START)))
         (COND
            (START (LET ((SUBNODES (IL:FETCH
 SUB-NODES IL:OF
 NODE)))
                        (WHEN (<= START END (CAR SUBNODES))
                            (SETF SUBNODES (NTHCDR START SUBNODES))
                            (DO ((STRUCTURE NIL)
                                 (INDEX START (1+ INDEX)))
                                ((> INDEX END)
                                 (NREVERSE STRUCTURE))
                              (PUSH (IL:FETCH
 STRUCTURE IL:OF
 (POP SUBNODES))
                                    STRUCTURE)))))
            (T (IL:FETCH
 STRUCTURE IL:OF
 NODE)))))

(DEFUN STRUCTURE-FROM-STRING
 (STR)

(IL:* IL:|;;;| "return all the structures that can be read from string as a list.  return a second value saying how many structures there were.  If an error is encountered, a second value of -1 is returned. ")


   (COND
      ((NULL STR)
       (VALUES NIL 0))
      ((STRINGP STR)
       (WITH-INPUT-FROM-STRING (S STR)
              (DO ((RESULTS NIL)
                   (EOF (LIST 'EOF))
                   (COUNT 0 (1+ COUNT))
                   VAL)
                  ((NULL (IL:NLSETQ (SETF VAL (READ S NIL EOF))))
                   (VALUES (NREVERSE RESULTS)
                          -1))
                (IF (EQ VAL EOF)
                    (RETURN (VALUES (NREVERSE RESULTS)
                                   COUNT))
                    (PUSH VAL RESULTS)))))
      (T (VALUES NIL -1))))

(DEFUN COMMENT-OUT-SELECTION
 (CONTEXT CHARCODE)

(IL:* IL:|;;;| "given a sequence of whole structure selections, build a 5 level comment node and replace the nodes with the comment.")


   (LET* ((SELECTION (IL:FETCH
 SELECTION IL:OF
 CONTEXT))
          (POINT (IL:FETCH
 CARET-POINT IL:OF
 CONTEXT))
          (NODE (IL:FETCH
 SELECT-NODE IL:OF
 SELECTION))
          (START (IL:FETCH
 SELECT-START IL:OF
 SELECTION))
          (STR (COND
                  ((OR (NULL NODE)
                       (NOT (EQ (IL:FETCH
 SELECT-TYPE IL:OF
 SELECTION)
                                'STRUCTURE)))
                   (FORMAT (GET-PROMPT-WINDOW CONTEXT)
                          "~%Select whole structure or structures to comment out.")
                   NIL)
                  (START (WITH-OUTPUT-TO-STRING (S)
                                (IL:BIND
 BLANK-BEFORE IL:FOR
 I IL:FROM
 START
                                   IL:TO
 (OR (IL:FETCH
 SELECT-END IL:OF
 SELECTION)
                                                 START) IL:AS
 X
                                   IL:ON
 (CDR (IL:NTH (IL:FETCH
 SUB-NODES IL:OF
 NODE)
                                                         START))
                                   IL:DO
 (IF BLANK-BEFORE
                                                 (WRITE-CHAR #\Space S)
                                                 (SETQ BLANK-BEFORE T))
                                         (PRIN1 (IL:FETCH
 STRUCTURE IL:OF
 (CAR X))
                                                S))))
                  (T (FORMAT NIL "~S" (IL:FETCH
 STRUCTURE IL:OF
 NODE))))))
         (WHEN STR
             (LET ((NEW-NODE (PARSE-NEW (LIST 'IL:* 'IL:\| STR)
                                    CONTEXT)))
                  (START-UNDO-BLOCK)
                  (DELETE-SELECTION
 CONTEXT)
                  (INSERT POINT CONTEXT NEW-NODE)
                  (SELECT-NODE CONTEXT NEW-NODE)
                  (IL:REPLACE
 PENDING-DELETE? IL:OF
 SELECTION IL:WITH
 NIL)
                  (END-UNDO-BLOCK))))
   T)
(IL:DEFINEQ

(add-menu

(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:27 by DCB") (let ((window (il:fetch display-window il:of context)) (promptwindow (get-prompt-window context)) menu) (cond ((il:windowprop window (quote menu)) (il:|printout| promptwindow t "This SEdit already has a menu.")) (t (il:|printout| promptwindow t "Creating menu...") (il:setq menu (get-menu context)) (il:attachwindow menu window nil nil (quote il:localclose)) (il:windowprop menu (quote il:rejectmaincoms) (quote (il:shapew))) (il:windowaddprop window (quote il:reshapefn) (quote il:repositionattachedwindows)) (il:windowprop window (quote menu) menu) (il:terpri promptwindow)))) t)
)

(backspace

(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:27 by DCB") (il:* il:|;;;| "implements the backspace key.  if there's a caret, find the appropriate method for the node it's in.  the type methods must take care of any selection as appropriate.  If there's a pending delete selection, consider backspace an undefined operation and punt, unless it's a quoted gap, let quote deal with it.") (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point))) (cond ((il:type? edit-node node) (funcall (il:fetch back-space il:of (il:fetch node-type il:of node)) node context (il:fetch point-index il:of point) (il:fetch point-string il:of point))) (node (let* ((selection node)) (when (and (il:setq node (il:fetch select-node il:of selection)) (eq type-gap (il:fetch node-type il:of node)) (eq type-quote (il:fetch node-type il:of (il:fetch super-node il:of node)))) (backspace-quote (il:fetch super-node il:of node) context t)))))) t)
)

(CHANGE-PACKAGE

  (IL:LAMBDA (CONTEXT CHARCODE NEW-PACKAGE NEW-PACKAGE-NAME)

                                                        (IL:* IL:\; "Edited  5-Dec-90 14:19 by woz")


(IL:* IL:|;;;| "new.package and new.package.name will be set if coming from the menu.  the menu selectedfn already checked valid package.  otherwise coming from the keyboard, and need to prompt.")


    (CLOSE-OPEN-NODE CONTEXT)
    (LET ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
          (WINDOW (IL:|fetch|
 DISPLAY-WINDOW IL:|of|
 CONTEXT)))
         (WHEN (NULL NEW-PACKAGE)
             (IL:TERPRI PROMPTWINDOW)
             (IL:SETQ NEW-PACKAGE-NAME (IL:U-CASE (IL:TTYINPROMPTFORWORD "New package: " 
                                                         PACKAGE-CANDIDATE NIL PROMPTWINDOW NIL NIL
                                                         (IL:CHARCODE (IL:CR ^X)))))

             (IL:* IL:|;;| "if have input then look for package, and if found reset candidate to full package name (user could have typed it abbreviation) of new package.")


             (IF (IL:STRINGP NEW-PACKAGE-NAME)
                 (IL:SETQ NEW-PACKAGE (FIND-PACKAGE NEW-PACKAGE-NAME)))
             (IF NEW-PACKAGE
                 (IL:SETQ PACKAGE-CANDIDATE (IL:SETQ NEW-PACKAGE-NAME (PACKAGE-NAME NEW-PACKAGE)))))
         (COND
            ((EQ NEW-PACKAGE *PACKAGE*)
             (FORMAT PROMPTWINDOW "~%Already editing in package ~A." NEW-PACKAGE-NAME))
            (NEW-PACKAGE (IL:SETQ *PACKAGE* NEW-PACKAGE)
                   (SAVE-PROFILE (IL:|fetch|
 PROFILE IL:|of|
 CONTEXT))
                   (VERIFY-STRUCTURE CONTEXT NIL NIL NIL T)
                   (WHEN (IL:WINDOWPROP WINDOW 'MENU)
                       (IL:FM.CHANGELABEL 'PACKAGE-NAME-ITEM NEW-PACKAGE-NAME (IL:WINDOWPROP
                                                                               WINDOW
                                                                               'MENU)))
                   (FORMAT PROMPTWINDOW "~%Now editing in package ~A" NEW-PACKAGE-NAME)
                   (IF (AND (NOT (EQ NEW-PACKAGE (FIND-PACKAGE "INTERLISP")))
                            (NOT (EQ NEW-PACKAGE (FIND-PACKAGE "LISP")))
                            (NOT (MEMBER (FIND-PACKAGE "LISP")
                                        (PACKAGE-USE-LIST NEW-PACKAGE)))
                            (NOT (MEMBER (FIND-PACKAGE "INTERLISP")
                                        (PACKAGE-USE-LIST NEW-PACKAGE))))
                       (FORMAT PROMPTWINDOW " (which does not use package LISP).")
                       (FORMAT PROMPTWINDOW ".")))
            (NEW-PACKAGE-NAME (IL:|printout| PROMPTWINDOW T "No such package: " NEW-PACKAGE-NAME))
            (T (IL:|printout| PROMPTWINDOW "...aborted"))))
    T))

(CHANGE-PRINTBASE

  (IL:LAMBDA (CONTEXT CHARCODE NEW-PRINTBASE)
       (IL:* IL:\; "Edited  5-Dec-90 14:18 by woz")


(IL:* IL:|;;;| "new.printbase will be set (and valid) if coming from the menu. otherwise, prompt.")


    (CLOSE-OPEN-NODE CONTEXT)
    (LET ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
          NEW-PRINTBASE-STRING)
         (WHEN (NULL NEW-PRINTBASE)
             (IL:TERPRI PROMPTWINDOW)
             (IL:SETQ NEW-PRINTBASE-STRING (IL:TTYINPROMPTFORWORD "New print-base: " 
                                                  PRINTBASE-CANDIDATE NIL PROMPTWINDOW NIL NIL
                                                  (IL:CHARCODE (IL:CR ^X))))
             (OR (AND (IL:STRINGP NEW-PRINTBASE-STRING)
                      (IL:SETQ NEW-PRINTBASE (IL:FIXP (CAR (IL:NLSETQ (IL:READ (IL:OPENSTRINGSTREAM
                                                                                NEW-PRINTBASE-STRING
                                                                                'IL:INPUT))))))
                      (IL:IGREATERP NEW-PRINTBASE 1)
                      (IL:ILEQ NEW-PRINTBASE 36)
                      (IL:SETQ PRINTBASE-CANDIDATE NEW-PRINTBASE-STRING))
                 (IL:SETQ NEW-PRINTBASE NIL)))
         (COND
            (NEW-PRINTBASE (IL:SETQ *PRINT-BASE* NEW-PRINTBASE)
                   (IL:SETQ *PRINT-RADIX* (IL:NEQ *PRINT-BASE* 10))
                   (SAVE-PROFILE (IL:|fetch|
 PROFILE IL:|of|
 CONTEXT))
                   (VERIFY-STRUCTURE CONTEXT NIL NIL NIL T)
                   (WHEN (IL:WINDOWPROP (IL:|fetch|
 DISPLAY-WINDOW IL:|of|
 CONTEXT)
                                'MENU)
                       (LET ((*PRINT-BASE* 10))              (IL:* IL:\; 

                                                           "make display be in base 10")

                            (IL:FM.CHANGESTATE 'PRINTBASE-VALUE-ITEM NEW-PRINTBASE
                                   (IL:WINDOWPROP (IL:|fetch|
 DISPLAY-WINDOW IL:|of|
 CONTEXT)
                                          'MENU)))))
            (T (IL:|printout| PROMPTWINDOW T "Illegal print-base: " NEW-PRINTBASE-STRING))))
    T))

(change-quote

(il:lambda (quote-node context quote-type) (il:* il:\; "Edited  7-Jul-87 09:27 by DCB") (rplaca (il:fetch structure il:of quote-node) (quote-wrapper quote-type)) (il:replace unassigned il:of quote-node il:with (il:listget (il:fetch quote-string il:of (il:fetch environment il:of context)) quote-type)) (note-change quote-node context))
)

(convert-comment

(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:27 by DCB") (let* ((promptwindow (get-prompt-window context)) (selection (il:fetch selection il:of context)) (point (il:fetch caret-point il:of context)) (node (il:fetch select-node il:of selection)) (start (il:fetch select-start il:of selection)) (number-of-comments 0) select-end) (cond ((and node (eq (il:fetch select-type il:of selection) (quote structure))) (il:* il:\; "there is a selection to substitute within") (cond (start (il:setq node (subnode start node)) (il:setq select-end (or (il:fetch select-end il:of selection) start))) (t (il:setq select-end (il:fetch sub-node-index il:of node)))) (start-undo-block) (il:bind (next-node il:_ node) (depth il:_ (il:fetch depth il:of node)) new-node il:while (il:setq node (find-comment next-node context depth select-end)) il:do (il:* il:|;;| "move past it so we're not  pointing to a dead node after the substitution") (il:setq next-node (next-node node t)) (when (not (il:fmemb (cadr (il:fetch structure il:of node)) comment-markers)) (il:* il:|;;| "this is an old comment.  convert it") (il:setq new-node (parse-new (convert-comment-structure (il:fetch structure il:of node)) context)) (replace-node context node new-node) (il:add number-of-comments 1)) (il:* il:|;;| "and continue the search")) (end-undo-block) (il:|printout| promptwindow t (if (eq 0 number-of-comments) "No" number-of-comments) (if (eq number-of-comments 1) " comment converted." " comments converted.")) (il:* il:|;;| "finally reset the point ") (when (not (eq 0 number-of-comments)) (set-point-nowhere point) (il:replace pending-delete? il:of selection il:with nil))) (t (il:|printout| promptwindow t "Select structure to convert comments within.")))) t)
)

(convert-comment-structure

(il:lambda (expr) (il:* il:\; "Edited 17-Jul-87 09:48 by DCB") (let (2-stars comtail comchar) (cond ((and (il:eqmemb (car expr) il:commentflg) (il:listp (cdr expr)) (not (il:fmemb (cadr expr) (quote (il:e il:declarations\: il:clisp\:)))) (il:listp (il:setq comtail (if (il:setq 2-stars (il:eqmemb (cadr expr) il:commentflg)) (cddr expr) (cdr expr))))) (il:setq comchar (or (car (il:listp il:commentflg)) il:commentflg)) (cond ((and (il:nlistp (cdr comtail)) (il:stringp (car comtail))) (il:* il:\; "already stringified.  now semicolonize") (cond (2-stars (il:push comtail level-3-comment)) ((il:igeq (il:nchars (car comtail)) convert-upgrade) (il:push comtail level-2-comment)) (t (il:push comtail level-1-comment))) (cons comchar comtail)) ((and (il:nlistp (cddr comtail)) (il:stringp (cadr comtail))) (il:* il:\; "could be an edit date") expr) (t (il:* il:|;;| "COMTAIL is where the comment starts, and this is not a funny evaluated comment.") (il:setq comtail (list (il:concatlist (convert-comment-tail comtail (cons))))) (cond (2-stars (il:push comtail level-3-comment)) ((il:igeq (il:nchars (car comtail)) convert-upgrade) (il:push comtail level-2-comment)) (t (il:push comtail level-1-comment))) (cons comchar comtail)))) (t (il:* il:\; "Not convertible") expr))))
)

(convert-comment-tail

(il:lambda (tail stream) (il:* il:\; "Edited 17-Jul-87 09:49 by DCB") (il:* il:|;;;| "to remove the dependency on WITH-OUTPUT-TO-STRING, which probably isn't very efficient and isn't available in koto anyway, we instead just accumulate a list of strings, and concatlist them at the end.  STREAM should be a TCONC pointer") (il:while tail il:bind il:x nspaces il:do (il:setq nspaces 1) (cond ((il:nlistp tail) (il:* il:\; "Dotted tail of some super list") (il:tconc stream " . ") (il:setq il:x tail) (il:setq tail nil)) (t (il:setq il:x (car tail)) (il:setq tail (cdr tail)))) (cond ((il:stringp il:x) (il:* il:\; "Turn quote marks into single quotes") (il:lconc stream (list "'" il:x "'"))) ((il:listp il:x) (il:tconc stream "(") (cond ((eq (car il:x) (quote -)) (il:* il:\; "Suppress line break that would occur here:  MAKE IT A BIG DASH") (il:tconc stream (if (cdr il:x) "--- " "---")) (il:pop il:x))) (convert-comment-tail il:x stream) (il:tconc stream ")") (il:selectq (car (il:listp tail)) ((il:\. il:\, il:\; il:?) (il:setq nspaces 0)) nil)) ((eq il:x (quote -)) (il:* il:\; "old style \"force line break\": MAKE IT A BIG DASH") (il:tconc stream "---")) (t (il:tconc stream il:x) (il:selcharq (il:nthcharcode il:x -1) ((il:\. il:\; il:?) (il:setq nspaces 2)) nil))) (cond ((and (il:neq nspaces 0) tail) (il:tconc stream (if (eq nspaces 1) " " "  "))))) (car stream))
)

(create-command-table

(il:lambda (description) (il:* il:\; "Edited 13-Jun-88 19:02 by Snow") (il:* il:|;;;| "each entry in the COMMAND-TABLE-SPEC should be of the form: (<fn> <help menu entry> <normalize?> <key>+) where <fn> is an atom function name or a list whose car is the function name and the rest are the extra arguments (beyond context and charcode), <help menu entry> is a list of strings for the name, key-name, and help-string, <normalize?> is T if the caret should be normalized after this command, and <key>+ is one or more key specifier which can be passed to charcode (if non-list) or whose car is a termtable syntax (if a list).") (let ((table (make-hash-table :size 95 :rehash-size 5)) (menu-items nil) (menu-left nil) (menu-right nil) fn entry) (il:|for| command il:|in| description il:|do| (il:* il:|;;| "get fn for this command.  The first thing in COMMAND is either an atom (a simple function name), or a list of the form (<fn-name> <extra-args>*).  Make a \"command form\" for sedit of the form (<fn-name> <normalize?> <extra-args>*)") (setq fn (if (consp (setq entry (first command))) (list* (first entry) (third command) (rest entry)) (list entry (third command)))) (il:* il:|;;| "check for help menu entry:  save left and right columns for tabulating later, and collect the menu items, without the label, but with the selectedfn and the help string.") (when (il:setq entry (second command)) (push (first entry) menu-left) (push (second entry) menu-right) (push (list (il:kwote fn) (third entry)) menu-items)) (il:* il:|;;| "for each of the keys for this command, make a table entry.  if key is a list, use the symbol in it to key on (for syntax and attached menu entries), else treat it as a charcode spec.") (il:|for| key il:|in| (cdddr command) il:|do| (setf (gethash (if (il:listp key) (car key) (charcode key)) table) fn))) (il:* il:|;;| "return list of command table and help menu items") (list table (list menu-items menu-left menu-right))))
)

(default-edit-fn

(il:lambda (obj options) (il:* il:\; "Edited  5-Jul-88 15:12 by woz") (ed obj (list* :display :dontwait options)))
)

(delete-selection

(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:27 by DCB") (il:* il:|;;| "delete the currently selected nodes, and set the caret point to where they were.  ") (let ((selection (il:fetch selection il:of context))) (and (il:fetch select-node il:of selection) (delete-nodes (il:fetch select-node il:of selection) context (il:fetch select-start il:of selection) (il:fetch select-end il:of selection) (il:fetch caret-point il:of context) (il:fetch select-string il:of selection))) (when (not (and (il:fetch select-node il:of selection) (eq type-gap (il:fetch node-type il:of (il:fetch select-node il:of selection))))) (set-selection-nowhere selection))) t)
)

(delete-word

(il:lambda (context) (il:* il:\; "Edited 24-Nov-87 10:02 by DCB") (close-open-node context) (let* ((point (il:fetch caret-point il:of context)) (selection (il:fetch selection il:of context)) (node (il:fetch point-node il:of point)) (end (il:fetch point-index il:of point)) (string (il:fetch point-string il:of point)) start) (il:* il:|;;| "don't do anything if there's no point or a pending delete selection.") (when (and node (or (not (il:fetch select-node il:of selection)) (not (il:fetch pending-delete? il:of selection)))) (il:selectq (il:fetch point-type il:of point) (atom (delete-nodes node context 1 end point string)) (esc-atom (delete-nodes node context 1 end point string)) (string (cond ((eq (il:fetch node-type il:of node) type-comment) (map-comment-index context node end) (cond ((il:igreaterp end 0) (delete-nodes node context (il:idifference (il:add1 end) (il:fetch \\x il:of context)) end point string)) ((null (cdr (il:fetch sub-nodes il:of node))) (delete-nodes node context nil nil point string)))) (t (il:setq start end) (cond ((il:igreaterp start 0) (il:* il:\; "backup over preceding whitespace") (il:while (and (il:neq start 1) (il:fmemb (il:nthcharcode string start) word-delim-chars)) il:do (il:setq start (il:sub1 start))) (il:* il:\; "backup over preceding word") (il:until (or (eq start 0) (il:fmemb (il:nthcharcode string start) word-delim-chars)) il:do (il:setq start (il:sub1 start))) (delete-nodes node context (il:add1 start) end point string)) ((eq 0 (il:nchars string)) (delete-nodes node context nil nil point string)))))) (structure (cond ((il:igreaterp end 0) (delete-nodes node context end nil point string)) ((null (cdr (il:fetch sub-nodes il:of node))) (delete-nodes node context nil nil point string)))) nil) (when (not (and (il:fetch select-node il:of selection) (eq type-gap (il:fetch node-type il:of (il:fetch select-node il:of selection))))) (il:* il:|;;| "cancel the selection unless its pending delete (ctrl-w doesn't do anything) or its a gap, which could have been created by the deletion.") (set-selection-nowhere selection)))) t)
)

(do-mutation

(il:lambda (context node mutator) (il:* il:\; "Edited  7-Jul-87 09:27 by DCB") (il:* il:|;;;| "this guy actually applies the mutation and replaces the sedit structure.  should return T if okay, and NIL if error occured durng mutation.") (let ((result (il:nlsetq (funcall mutator (il:fetch structure il:of node))))) (when result (il:* il:|;;| "assume result is not equal to node's Structure.  otherwise, why would mutate have been called?") (replace-node context node (parse-new (car result) context)) (il:* il:\; "return T") t)))
)

(edit-selection

(il:lambda (context charcode options) (il:* il:\; "Edited  5-Jul-88 15:53 by woz") (let ((structure (get-selected-structure context))) (cond (structure (cond ((funcall *edit-fn* structure options) (set-selection-nowhere (il:fetch (edit-context selection) il:of context)) (set-point-nowhere (il:fetch (edit-context caret-point) il:of context))))) (t (format (get-prompt-window context) "~%Select name of object to edit.")))) t)
)

(eval-selection

(il:lambda (context) (il:* il:\; "Edited 29-Oct-87 15:14 by drc:") (il:* il:|;;;| "evaluate the selected structure in the appropriate process, which should be stored in the EvalInProcess field of the context.  If this field is NIL, then the process went away unexpectedly, so find an exec to eval in.  This is dangerous: FIND.PROCESS 'EXEC IS NOT GUARANTEED!") (let* ((structure (get-selected-structure context)) (structure-copy (copy-tree structure)) (process (il:fetch eval-in-process il:of context)) (promptwindow (get-prompt-window context)) (value (quote il:nobind))) (il:terpri promptwindow) (when (not (il:processp process)) (il:setq process (il:replace eval-in-process il:of context il:with (il:find.process (quote il:mouse))))) (cond ((null structure) (il:|printout| promptwindow t "Invalid selection for evaluation.")) ((il:listp structure) (il:setq value (il:resetform (il:tty.process process) (il:process.eval process (il:bquote (il:ersetq (il:\\\, structure))) t))) (unless (equal structure structure-copy) (il:* il:|;;| "eval (DWIM) changed the structure") (replace-node context (il:fetch select-node il:of (il:fetch selection il:of context)) (parse-new structure context))) (if value (il:setq value (car value)) (il:setq value (quote il:nobind)))) ((il:numberp structure) (il:* il:|;;| "make numbers eval to themselves, since PROCESS.EVALV won't work") (il:setq value structure)) ((il:atom structure) (il:setq value (il:process.evalv process structure)) (when (eq value (quote il:nobind)) (il:|printout| promptwindow t "Unbound atom: " il:|.P2| structure))) (t (il:setq value structure))) (when (il:neq value (quote il:nobind)) (cond ((or (il:atom value) (il:stringp value)) (il:|printout| promptwindow t "Result: " il:|.P2| value)) (t (set-selection-nowhere (il:fetch (edit-context selection) il:of context)) (inspect value))))) t)
)

(expand

(il:lambda (context charcode) (il:* il:\; "Edited  7-Jan-88 13:43 by DCB") (il:* il:|;;;| "Replace the current selection with its macro-expansion, if any.") (let* ((promptwindow (get-prompt-window context)) (selection (il:fetch selection il:of context)) (point (il:fetch caret-point il:of context)) (node (il:fetch select-node il:of selection))) (cond ((and node (eq (il:fetch select-type il:of selection) (quote structure)) (null (il:fetch select-start il:of selection))) (let ((structure (il:fetch structure il:of node)) expansion) (when (consp structure) (il:* il:|;;| "we have a whole list structure node selected.  try to expand its definition") (il:|printout| promptwindow t "Looking for expansion...") (il:setq expansion (il:nlsetq (il:editgetd structure))) (cond ((null expansion) (il:|printout| promptwindow t "Error during macro expansion.")) ((not (equal (car expansion) structure)) (il:terpri promptwindow) (replace-node context node (parse-new (car expansion) context))) (t (il:|printout| promptwindow t "No expansion found.")))))) (t (il:|printout| promptwindow t "Can't expand this selection.")))) t)
)

(extract-current-selection

(il:lambda (context) (il:* il:\; "Edited 27-Jun-88 15:30 by woz") (close-open-node context) (let* ((promptwindow (get-prompt-window context)) (selection (il:|fetch| selection il:|of| context)) (point (il:|fetch| caret-point il:|of| context)) (node (il:|fetch| select-node il:|of| selection)) subnodes set-selection?) (when (and (null node) (il:setq node (il:|fetch| point-node il:|of| point)) (eq (il:|fetch| point-type il:|of| point) (quote structure))) (il:* il:|;;| "when you've only got a structure point extract from the list pointed within") (set-selection-me selection context node)) (cond ((or (null node) (il:neq (il:|fetch| select-type il:|of| selection) (quote structure)) (il:|fetch| select-start il:|of| selection) (il:|fetch| select-end il:|of| selection)) (il:|printout| promptwindow t "Select structure to extract.")) ((eq 0 (car (il:|fetch| sub-nodes il:|of| node))) (il:* il:\; "nothing to extract") (il:|printout| promptwindow t "Nothing to extract.")) ((eq (il:|fetch| node-type il:|of| node) type-comment) (let ((start 0) (string (third (il:fetch structure il:of node))) structure new-structures) (cond ((il:nlsetq (loop (if (eq :sedit-read-end-flg (multiple-value-setq (structure start) (read-from-string string nil :sedit-read-end-flg :start start))) (return t) (push structure new-structures)))) (setq subnodes (mapcar (function (lambda (s) (parse-new s context))) (nreverse new-structures))) (unless (cdr subnodes) (setq set-selection? (car subnodes))) (pending-delete point selection) (insert point context subnodes)) (t (format promptwindow "~%Unreadable structure in comment.  Can't Extract."))))) (t (il:|replace| point-node il:|of| point il:|with| selection) (il:|replace| point-type il:|of| point il:|with| (quote structure)) (il:setq subnodes (cdr (il:|fetch| sub-nodes il:|of| node))) (unless (cdr subnodes) (setq set-selection? (car subnodes))) (rplacd (il:|fetch| sub-nodes il:|of| node) nil) (start-undo-block) (undo-by undo-extract node subnodes) (il:* il:\; "replace with subnodes") (insert point context (il:copy subnodes)) (end-undo-block))) (when set-selection? (il:* il:|;;| "if only one subnode, leave it selected") (set-selection-me selection context set-selection?) (il:|replace| pending-delete? il:|of| selection il:|with| nil))) (il:* il:|;;| "must return non-NIL if command executed") t)
)

(find-comment

(il:lambda (node context min-depth last-subnode) (il:* il:\; "Edited  3-Dec-87 12:54 by DCB") (il:* il:|;;;| "search starting with NODE for a node whose structure begins with a comment char .  move selection and point accordingly. return the node found, else NIL") (when node (il:bind (commentchar il:_ (if (il:listp il:commentflg) (car il:commentflg) il:commentflg)) il:until (or (null node) (il:ilessp (il:fetch depth il:of node) min-depth) (and (eq (il:fetch depth il:of node) min-depth) (il:igreaterp (il:fetch sub-node-index il:of node) last-subnode))) il:do (when (eq commentchar (car (il:fetch structure il:of node))) (return node)) (il:setq node (next-node node)))))
)

(get-menu

(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:28 by DCB") (let (menu) (cond ((il:setq menu (il:pop menus)) (il:fm.resetmenu menu)) (t (il:setq menu (il:freemenu menu-description "SEdit Command Menu")) (il:windowaddprop menu (quote il:closefn) (quote menu-closefn)) (il:windowprop menu (quote il:fm.dontreshape) t))) (menu-init-state menu context) menu))
)

(edit-help

(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:29 by DCB") (close-open-node context) (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point))) (when (and (il:type? edit-node node) (il:litatom (il:fetch structure il:of node)) (eq (il:fetch point-index point) (il:nchars (il:fetch structure il:of node)))) (il:* il:\; "if at end of this node, change to structure point.") (insert point context nil))) (let* ((fname (selected-fn-name context)) (promptwindow (get-prompt-window context)) args) (if fname (if (il:setq args (il:nlsetq (il:smartarglist fname t))) (cond ((il:ileq (il:stringwidth (il:setq args (cons fname (car args)))) (il:windowprop promptwindow (quote il:width))) (il:* il:\; "will fit in attached window") (il:|printout| promptwindow t args)) (t (il:* il:\; "put in main promptwindow") (il:terpri promptwindow) (il:|printout| il:promptwindow t args))) (il:|printout| promptwindow t "Arguments not available for " fname)) (il:|printout| promptwindow t "Select function you want the arguments for."))) t)
)

(helpmenu

(il:lambda (context) (il:* il:\; "Edited 24-May-88 14:20 by woz") (let ((menu (il:fetch help-menu il:of (il:fetch environment il:of context))) (promptwindow (get-prompt-window context)) command) (when (listp menu) (format promptwindow "~%Creating menu, please wait...") (il:* il:|;;| "build the popup menu info.  the lists of menu-items, menu-left strings, and menu-right strings are in the MENU list.  take it apart, then build the menu.  this information was compiled in create-command-table, but the menu gets built when first used (so the font ends up right if the user changed it).") (let* ((font (il:fontcreate il:menufont)) (menu-items (first menu)) (equalized-menu-left (equalize-string-widths (second menu) font)) (menu-right (third menu)) itemwidth items) (il:* il:|;;| "figure out the width of the left column, including the tab, then set the menu width.  Do this by finding the first tab stop after the shortest stringwidth in EQUALIZED-MENU-LEFT.  We know that the widths of each equalized string are within one space width of each other, and since a tab is bigger than a space, we know that this tab stop is the first after all of the strings, allowing tabulation.") (il:* il:|;;| "There is a strange feature of the menu code that starts printing lables at 1 instead of zero, which changes the relative tab stop position.  This shift can cause a tab stop to fall in between the shortest and longest equalized strings.  So we have to see if our chosen tab stop is within one pixel of the longest string, and if so, pad the strings with an extra space to jump them all past that tab stop.") (do* ((left-width (minimum-string-width equalized-menu-left font)) (tab-width (il:stringwidth "        " font)) (tab-column tab-width (+ tab-column tab-width))) ((> tab-column left-width) (il:* il:|;;| "check for the stupid menu case:") (when (= (1- tab-column) (maximum-string-width equalized-menu-left font)) (setq equalized-menu-left (equalize-string-widths equalized-menu-left font nil tab-column)) (incf tab-column tab-width)) (setq itemwidth (+ tab-column (maximum-string-width menu-right font)))) nil) (il:* il:|;;| "construct the menu strings and the menu items.") (do ((left equalized-menu-left (rest left)) (right menu-right (rest right)) (item menu-items (rest item))) ((null item) (setq items (nreverse menu-items))) (push (concatenate (quote string) (first left) (string #\Tab) (first right)) (first item))) (il:replace help-menu il:of (il:fetch environment il:of context) il:with (setq menu (il:create il:menu il:items il:_ items il:itemwidth il:_ itemwidth il:changeoffsetflg il:_ (quote il:y) il:menuoffset il:_ (cons -1 0) il:title il:_ "Commands"))))) (when (setq command (il:menu menu)) (terpri promptwindow) (awake-command-process context command))))
)

(input-dot

(il:lambda (context charcode) (il:* il:\; "Edited  7-Jul-87 09:29 by DCB") (il:* il:|;;;| "handle input of a dot.  cases: ") (il:* il:|;;;| "(1) structure selection; might be a quoted gap to be ugraded, otherwise just a node to delete in a list to be dotted.") (il:* il:|;;;| "(2) structure point; in a list to be dotted.") (il:* il:|;;;| "(3) atom point; might be at the beginning of a quote to be ugraded, otherwise just insert the dot.") (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point))) (cond ((il:type? edit-selection node) (let ((selection node)) (il:* il:|;;| "if we're at a structure selection, this is interesting.  otherwise, let the char handler input the dot. ") (when (eq (quote structure) (il:fetch select-type il:of selection)) (cond ((eq type-quote (il:fetch node-type il:of (if (il:fetch select-start il:of selection) (il:fetch select-node il:of selection) (il:fetch super-node il:of (il:fetch select-node il:of selection))))) (il:* il:|;;| "we're in a quote form.  let the quote handler check for a comma-dot") (input-quote context charcode (quote comma-dot)) t) (t (il:* il:|;;| "just at a pending delete selection.  delete it and try to dot the list.") (delete-nodes (il:fetch select-node il:of selection) context (il:fetch select-start il:of selection) (il:fetch select-end il:of selection) point) (dot-this-list context) t))))) ((and node (eq (quote structure) (il:fetch point-type il:of point))) (il:* il:|;;| "normal case of dot input at a structure point in a list") (dot-this-list context) t) ((and node (eq (quote atom) (il:fetch point-type il:of point)) (eq 0 (il:fetch point-index il:of point))) (il:* il:|;;| "at the beginning of an atom.  check if it's a comma quote, otherwise, just input") (let ((super-node (il:fetch super-node il:of node))) (when (and (eq type-quote (il:fetch node-type il:of super-node)) (eq (quote-wrapper (quote il:comma)) (car (il:fetch structure il:of super-node)))) (il:* il:|;;| "we're at the beginning of a COMMA quote atom that wants to be upgraded") (change-quote super-node context (quote comma-dot)) t))))))
)

(input-escape

(il:lambda (context) (il:* il:\; "Edited 17-Nov-87 13:35 by DCB") (il:* il:|;;;| "dynamically set this.char.escaped true, so that next time through the loop, it knows it's getting an escaped char") (il:setq this-char-escaped t))
)

(input-normal-char

(il:lambda (context char) (il:* il:\; "Edited  7-Jul-87 09:29 by DCB") (cond ((and (il:igreaterp char 255) (il:ilessp char 512)) (il:* il:|;;| "this is a meta-character that wasn't recognized as a command.  don't insert it!") (il:|printout| (get-prompt-window context) t "Unknown command: Meta-" (il:character (il:idifference char 256)))) (t (let ((point (il:fetch (edit-context caret-point) il:of context)) (point-type (type-of-input context))) (il:setq char (il:character char)) (when (il:neq point-type (quote string)) (cond (this-char-escaped (il:* il:|;;| "prepend an escape character") (il:* il:\; "read table specific") (il:setq char (il:concat (il:character (escape-char)) char))) ((and (il:fetch (readtablep il:caseinsensitive) il:of *readtable*) (il:neq point-type (quote esc-atom))) (il:setq char (if (or (eq point-type (quote structure)) (eq *print-case* (quote :upcase))) (il:u-case char) (il:l-case char)))))) (il:selectq point-type (structure (il:* il:|;;| "first mark that we're starting an atom, because the reparser needs to know when inserting in a lambda arglist slot whether or not to reparse it as a list.  THIS IS UGLY, but it works.") (il:replace atom-started il:of context il:with t) (insert point context char) (il:replace atom-started il:of context il:with (il:fetch point-node il:of point)) (il:replace atom-started-undo-pointer il:of context il:with (il:fetch undo-list il:of context))) ((atom esc-atom) (let ((node (il:fetch point-node il:of point)) il:where) (cond ((il:type? edit-node node) (il:setq il:where point)) (t (il:* il:|;;| "the pending-delete case.  the PointNode actually points to a selection framing the material to be replaced") (il:setq node (il:fetch select-node il:of (il:setq il:where node))))) (insert-string node context il:where char point) (set-selection-nowhere (il:fetch selection il:of context)))) (string (insert point context char)) (nil) (il:shouldnt "bad point type"))))) (set-selection-nowhere (il:fetch (edit-context selection) il:of context)))
)

(input-quote

(il:lambda (context charcode quote-type) (il:* il:\; "Edited 19-Nov-87 15:28 by DCB") (il:selectq (type-of-input context) (structure (close-open-node context) (cond ((il:fmemb quote-type (quote (comma-at comma-dot))) (il:* il:|;;| "check if we're in a COMMA quote to be upgraded") (let* ((selection (il:fetch selection il:of context)) (node (il:fetch select-node il:of selection)) (super-node)) (when (and node (il:setq super-node (il:fetch super-node il:of node)) (eq type-gap (il:fetch node-type il:of node)) (eq type-quote (il:fetch node-type il:of super-node)) (eq (quote-wrapper (quote il:comma)) (car (il:fetch structure il:of super-node)))) (il:* il:|;;| "we're in the middle of typing in a COMMA quote form that wants to be upgraded") (change-quote super-node context quote-type) t))) (t (insert-quoted-gap context charcode quote-type) t))) (atom (il:* il:|;;| "check if we're at the beginning of an atom to quote.  otherwise, let the quote be inserted normally") (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point)) (super-node (and (il:type? edit-node node) (il:fetch super-node il:of node)))) (cond ((and super-node (eq 0 (il:fetch point-index point))) (cond ((eq quote-type (quote comma-at)) (il:* il:|;;| "this is tricky.  we got an @ at the beginning of an atom.  if it's in a COMMA quote, then upgrade, otherwise insert the @ as part of the atom.") (when (and (eq type-quote (il:fetch node-type il:of super-node)) (eq (quote-wrapper (quote il:comma)) (car (il:fetch structure il:of super-node)))) (change-quote super-node context (quote comma-at)) t)) (t (set-selection-me (il:fetch selection il:of context) context node) (quote-current-selection context charcode quote-type) (set-selection-nowhere (il:fetch selection il:of context)) (set-point point context node) t))) ((and super-node (eq quote-type (quote quote)) (eq 1 (il:fetch point-index point)) (eq (il:charcode \#) (il:chcon1 (il:fetch point-string il:of point)))) (il:* il:|;;| "this is tricky.  We are adding the ' part of #', so we want to function wrap the rest of this string (or gap it if it's empty).") (cond ((eq 1 (il:nchars (il:fetch point-string il:of point))) (il:* il:|;;| "close the node, get rid of it, and replace it with a quoted gap.  Oh yeah, do this undoably by just closing and calling an undoable thing,") (close-open-node context) (set-selection-me (il:fetch selection il:of context) context node) (pending-delete point (il:fetch selection il:of context)) (insert-quoted-gap context nil (quote function)) t) (t (il:* il:|;;| "remove the #, close the node, wrap it with function, and put point at the first character.  Oh yeah, do this undoably.") (start-undo-block) (replace-string node context 1 1 "" point (il:fetch point-string il:of point) (quote atom)) (set-selection-me (il:fetch selection il:of context) context node) (quote-current-selection context nil (quote function)) (set-selection-nowhere (il:fetch selection il:of context)) (set-point point context node nil nil nil (quote atom)) (end-undo-block) t)))))) nil))
)

(input-square-bracket

(il:lambda (context charcode) (il:* il:\; "Edited  7-Jul-87 09:29 by DCB") (when (il:neq (type-of-input context) (quote string)) (let ((promptwindow (get-prompt-window context))) (il:|printout| promptwindow t "SEdit can't handle square brackets.  Ignoring rest of input.") (il:flashwindow promptwindow) (il:clearbuf t) t)))
)

(input-stringdelim

(il:lambda (context) (il:* il:\; "Edited 17-Nov-87 13:35 by DCB") (cond ((eq (type-of-input context) (quote string)) (il:* il:|;;| "split or close this string") (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point))) (when (il:type? edit-selection node) (il:setq node (il:fetch select-node il:of node))) (when (eq (il:fetch node-type il:of node) type-string) (insert point context nil) (set-selection-nowhere (il:fetch (edit-context selection) il:of context)) t))) (t (il:* il:|;;| "insert a new string") (let ((new-string (il:allocstring 0)) (point (il:fetch (edit-context caret-point) il:of context))) (il:setq new-string (create-simple-node new-string (il:fetch environment il:of context) type-string new-string t (il:fetch default-font il:of (il:fetch environment il:of context)))) (insert point context new-string) (when (not (dead-node? new-string)) (il:replace point-node il:of point il:with new-string) (il:replace point-index il:of point il:with 0) (il:replace point-type il:of point il:with (quote string)) (il:replace point-string il:of point il:with (il:fetch structure il:of new-string)) (set-selection-nowhere (il:fetch (edit-context selection) il:of context)) (il:replace atom-started il:of context il:with new-string) (il:replace atom-started-undo-pointer il:of context il:with (il:fetch undo-list il:of context)))) t)))
)

(input-tokendelim

(il:lambda (context charcode) (il:* il:\; "Edited  7-Jul-87 09:29 by DCB") (let ((point (il:fetch caret-point il:of context))) (il:selectq (type-of-input context) (atom (insert point context nil) (set-selection-nowhere (il:fetch (edit-context selection) il:of context))) (structure (when (not (il:fetch pending-delete? il:of (il:fetch selection il:of context))) (il:* il:|;;| "this test so that delims don't do anything on pending delete gaps in particular, to avoid <dot> <space> or <quote> <space> wasting the gap.  i don't think it will hurt the other cases.") (insert point context nil) (set-selection-nowhere (il:fetch (edit-context selection) il:of context)))) ((string esc-atom) (if (and (eq charcode (il:charcode il:cr)) (eq-point-type point type-comment)) (insert point context nil) (insert point context (il:character charcode))) (set-selection-nowhere (il:fetch (edit-context selection) il:of context))) (nil) (il:shouldnt "bad point type"))) t)
)

(insert-multi-escape

(il:lambda (context char) (il:* il:\; "Edited  7-Jul-87 09:29 by DCB") (let ((point (il:fetch caret-point il:of context)) (type (type-of-input context)) node il:where) (cond ((eq type (quote structure)) (insert point context (il:allocstring 2 char)) (il:replace point-index il:of point il:with 1) (il:replace point-type il:of point il:with (quote esc-atom))) ((or (eq type (quote atom)) (eq type (quote esc-atom))) (if (il:type? edit-node (il:setq node (il:fetch point-node il:of point))) (if (and (eq type (quote esc-atom)) (eq (il:nthcharcode (il:fetch point-string il:of point) (il:add1 (il:fetch point-index il:of point))) char)) (il:add (il:fetch point-index il:of point) 1) (il:setq il:where point)) (il:setq node (il:fetch select-node il:of (il:setq il:where node)))) (when il:where (insert-string node context il:where (il:allocstring 2 char) point) (il:add (il:fetch point-index il:of point) -1)) (il:replace point-type il:of point il:with (if (eq (il:fetch point-type il:of point) (quote atom)) (quote esc-atom) (quote atom))) (set-selection-nowhere (il:fetch selection il:of context)) t))))
)

(insert-special-character

(il:lambda (context char) (il:* il:\; "Edited  7-Jul-87 09:29 by DCB") (il:* il:|;;;| "insert a special character (e.g.  the package delimiter) without escaping it") (let ((point (il:fetch caret-point il:of context)) (string (il:allocstring 1 char))) (il:selectq (type-of-input context) (atom (let ((node (il:fetch point-node il:of point)) il:where) (cond ((il:type? edit-node node) (il:setq il:where point)) (t (il:* il:|;;| "the pending-delete case.  the PointNode actually points to a selection framing the material to be replaced") (il:setq node (il:fetch select-node il:of (il:setq il:where node))))) (insert-string node context il:where string point) (set-selection-nowhere (il:fetch selection il:of context)) t)) (structure (il:* il:|;;| "LET ((new.node (fetch PointNode of point))) (replace AtomStarted of context with new.node) (replace AtomStartedUndoPointer of context with (fetch UndoList of context)) (open.litatom context new.node string) (replace OpenNodeChanged?  of context with T) (adjust.width new.node context (STRINGWIDTH string) (fetch Font of (CAR (fetch LinearForm of new.node)))) (replace PointIndex of point with 1) (replace PointString of point with string) T") (insert point context string) t) nil)))
)

(inspect-selection

(il:lambda (context) (il:* il:\; "Edited 17-Nov-87 13:36 by DCB") (let ((structure (get-selected-structure context))) (cond (structure (set-selection-nowhere (il:fetch (edit-context selection) il:of context)) (set-point-nowhere (il:fetch (edit-context caret-point) il:of context)) (il:* il:|;;| "update context") (when (null (il:nlsetq (inspect structure))) (il:|printout| (get-prompt-window context) t "Inspection aborted."))) (t (il:|printout| (get-prompt-window context) t "Select object to inspect.")))) t)
)

(join

(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:36 by DCB") (let* ((promptwindow (get-prompt-window context)) (selection (il:fetch selection il:of context)) (point (il:fetch caret-point il:of context)) (node (il:fetch select-node il:of selection)) (start (il:fetch select-start il:of selection)) (end (il:fetch select-end il:of selection)) (comment-level 1) subnodes type new-structure new-node) (close-open-node context) (cond ((not (and node start end (il:neq start end) (eq (il:fetch select-type il:of selection) (quote structure)))) (il:|printout| promptwindow t "Select items to join.")) ((and (il:setq type (il:fetch name il:of (il:fetch node-type il:of (subnode start node)))) (il:fmemb type (il:constant (quote (quote unknown gap root dotlist))))) (il:|printout| promptwindow t "Can't join things of this type.")) (t (il:setq subnodes (il:fetch sub-nodes il:of node)) (pending-delete point selection) (start-undo-block) (il:selectq type ((litatom string) (il:* il:|;;| "for these types, each node must be of the same SEdit type") (il:setq new-structure (il:for index il:from start il:to end il:as subnode il:in (il:nth (cdr subnodes) start) il:collect (when (not (il:fmemb (il:fetch name il:of (il:fetch node-type il:of subnode)) (il:constant (quote (litatom string))))) (il:|printout| promptwindow t "Each item to join must be of the same type.") (return)) (il:fetch structure il:of subnode))) (when new-structure (cond ((il:numberp (car new-structure)) (il:|printout| promptwindow t "Can't join numbers.")) (t (il:setq new-node (parse-new (if (eq type (quote litatom)) (intern (il:concatlist new-structure) (symbol-package (car new-structure))) (il:concatlist new-structure)) context)) (insert point context new-node))))) (comment (il:* il:|;;| "for comments, each node must be of the same SEdit type") (il:setq new-structure (il:for index il:from start il:to end il:as subnode il:in (il:nth (cdr subnodes) start) il:join (when (il:neq (il:fetch name il:of (il:fetch node-type il:of subnode)) (quote comment)) (il:|printout| promptwindow t "Each item to join must be of the same type.") (return)) (il:setq comment-level (il:imax comment-level (il:fetch unassigned il:of subnode))) (cond ((eq index end) (cddr (il:fetch structure il:of subnode))) (t (il:* il:|;;| "add space between comments") (list (caddr (il:fetch structure il:of subnode)) "  "))))) (when new-structure (il:setq new-structure (list (quote il:*) (car (il:nth comment-markers comment-level)) (il:apply* (quote il:concatlist) new-structure))) (il:setq new-node (parse-new new-structure context)) (insert point context new-node))) (progn (il:* il:|;;| "for the rest, the structures must all be listp's") (cond ((il:for index il:from start il:to end il:as subnode il:in (il:nth (cdr subnodes) start) il:thereis (not (il:listp (il:fetch structure il:of subnode)))) (il:|printout| promptwindow t "Each item to join must be of the same type.")) (t (il:setq new-node (subnode start node)) (set-point point context new-node (car (il:fetch sub-nodes il:of new-node)) t (car (last (il:fetch sub-nodes il:of new-node))) (quote structure)) (il:for index il:from (il:add1 start) il:to end il:as subnode il:in (il:nth (cdr subnodes) (il:add1 start)) il:do (il:setq new-structure (cdr (il:fetch sub-nodes il:of subnode))) (delete-nodes subnode context 1 (car (il:fetch sub-nodes il:of subnode))) (insert point context new-structure)) (delete-nodes node context (il:add1 start) end))))) (when new-node (set-selection-me selection context new-node) (il:replace pending-delete? il:of selection il:with nil) (set-point point context new-node nil t nil (quote structure))) (end-undo-block)))) t)
)

(menu-closefn

(il:lambda (w) (il:* il:\; "Edited  7-Jul-87 09:36 by DCB") (il:* il:|;;;| "must be called before menu is detached from sedit.") (il:push menus w) (il:windowprop (il:mainwindow w) (quote menu) nil))
)

(menu-find-selectedfn

(il:lambda (item window buttons) (il:* il:\; "Edited 17-Jul-87 10:12 by DCB") (let ((find-item (il:listget (il:fm.itemprop item (quote il:links)) (quote il:edit))) (context (il:windowprop (il:mainwindow window) (quote edit-context)))) (cond ((or (il:equal (il:fm.itemprop find-item (quote il:label)) "") (eq (car buttons) (quote il:right))) (il:* il:|;;| "need new stuff to find") (il:fm.edititem find-item window t)) (t (il:* il:|;;| "call find with an extra argument of the stuff to find") (menu-selectedfn item window buttons (quote find) (list (il:fm.itemprop find-item (quote il:label)))) (il:tty.process (il:windowprop (il:mainwindow window) (quote il:process)))))))
)

(menu-init-state

(il:lambda (menu context) (il:* il:\; "Edited  7-Jul-87 09:38 by DCB") (il:* il:|;;;| "initialize menu profile entries.  will be called by either under command loop, or under building new window, either case under sedit's profile, so references to *print* variables are okay.") (let* ((package-name (package-name *package*)) (print-base *print-base*) (*print-base* 10)) (il:* il:|;;| "want to display *PRINT-BASE* in print base 10, so must cache and rebind it.") (il:fm.changestate (quote printbase-value-item) print-base menu) (il:fm.itemprop (il:fm.getitem (quote printbase-item) nil menu) (quote printbase) print-base) (il:fm.changelabel (quote package-name-item) package-name menu) (il:fm.itemprop (il:fm.getitem (quote package-item) nil menu) (quote package-name) package-name)))
)

(menu-package-selectedfn

(il:lambda (item window buttons) (il:* il:\; "Edited 17-Jul-87 10:13 by DCB") (il:* il:|;;;| "check if the new package name is valid and if so initiate the package change by waking up the comand process to handle the command.  otherwise error and reset the package name in the menu to the name of the current package, which is cached on this item.") (let* ((package-name-item (il:listget (il:fm.itemprop item (quote il:links)) (quote il:edit))) (package-name (il:fm.itemprop package-name-item (quote il:label))) package) (cond ((or (il:equal package-name "") (eq (car buttons) (quote il:right))) (il:fm.edititem package-name-item window t)) ((il:setq package (find-package package-name)) (il:fm.itemprop item (quote package-name) package-name) (menu-selectedfn item window buttons (quote set-package) (list package package-name))) (t (il:|printout| (il:getpromptwindow (il:mainwindow window)) t "No such package: " package-name) (il:fm.changelabel package-name-item (il:fm.itemprop item (quote package-name)) window)))))
)

(menu-printbase-selectedfn

(il:lambda (item window buttons) (il:* il:\; "Edited 17-Jul-87 10:13 by DCB") (il:* il:|;;;| "make sure there is a valid printbase value, and if so, change sedits printbase to it.") (let* ((printbase-value-item (il:listget (il:fm.itemprop item (quote il:links)) (quote il:edit))) (print-base (il:fm.itemprop printbase-value-item (quote il:state)))) (cond ((or (null print-base) (eq (car buttons) (quote il:right))) (il:fm.edititem printbase-value-item window t)) ((and (il:igreaterp print-base 1) (il:ileq print-base 36)) (il:fm.itemprop item (quote printbase) print-base) (menu-selectedfn item window buttons (quote set-print-base) (list print-base))) (t (il:|printout| (il:getpromptwindow (il:mainwindow window)) t "Illegal print-base: " print-base) (il:fm.changestate printbase-value-item (il:fm.itemprop item (quote printbase)) window)))))
)

(menu-selectedfn

(il:lambda (item window buttons command extra-args) (il:* il:\; "Edited 17-Jul-87 10:13 by DCB") (let ((context (il:windowprop (il:mainwindow window) (quote edit-context)))) (awake-command-process context (il:append (lookup-command (or command (il:fm.itemprop item (quote il:id)) (il:fm.itemprop item (quote il:label))) (il:fetch command-table il:of (il:fetch environment il:of context))) extra-args))))
)

(menu-substitute-selectedfn

(il:lambda (item window buttons) (il:* il:\; "Edited 17-Jul-87 09:57 by DCB") (let ((find-item (il:listget (il:fm.itemprop item (quote il:links)) (quote finditem))) (subitem (il:listget (il:fm.itemprop item (quote il:links)) (quote il:edit))) (context (il:windowprop (il:mainwindow window) (quote edit-context)))) (cond ((il:equal (il:fm.itemprop find-item (quote il:label)) "") (il:* il:\; "need new stuff to find") (il:fm.edititem find-item window t)) ((or (il:equal (il:fm.itemprop subitem (quote il:label)) "") (eq (car buttons) (quote il:right))) (il:* il:\; "need new stuff to substitute") (il:fm.edititem subitem window t)) (t (il:* il:\; "call substitute with all the stuff to substitute") (menu-selectedfn item window buttons (quote substitute) (list (il:fm.itemprop find-item (quote il:label)) (il:fm.itemprop subitem (quote il:label)))) (il:tty.process (il:windowprop (il:mainwindow window) (quote il:process)))))))
)

(mutate

(il:lambda (context) (il:* il:\; "Edited 11-Apr-88 15:58 by woz") (let* ((promptwindow (get-prompt-window context)) (selection (il:|fetch| selection il:|of| context)) (point (il:|fetch| caret-point il:|of| context)) (node (il:|fetch| select-node il:|of| selection)) mutator-string mutator result) (cond ((and node (eq (il:|fetch| select-type il:|of| selection) (quote structure)) (null (il:|fetch| select-start il:|of| selection))) (il:terpri promptwindow) (il:setq mutator-string (il:ttyinpromptforword "Mutate by function: " mutate-candidate nil promptwindow nil nil (il:charcode (il:cr ^x)))) (cond ((il:stringp mutator-string) (il:setq mutator (il:nlsetq (il:read (il:openstringstream mutator-string (quote il:input))))) (if mutator (if (do-mutation context node (car mutator)) (il:setq mutate-candidate mutator-string) (il:|printout| promptwindow t "Error during mutation.  No changes made.")) (il:|printout| promptwindow t "Invalid function name: " mutator-string))) (t (il:|printout| promptwindow "...aborted")))) (t (il:|printout| promptwindow t "Select whole structure to mutate."))) t))
)

(quote-current-selection

(il:lambda (context charcode quote-type) (il:* il:\; "Edited 13-Jan-88 13:26 by DCB") (close-open-node context) (let* ((selection (il:fetch selection il:of context)) (point (il:fetch caret-point il:of context)) (node (il:fetch select-node il:of selection)) (quote-node)) (when (and node (eq (il:fetch select-type il:of selection) (quote structure))) (il:setq quote-node (create-quoted-gap basic-gap context quote-type)) (start-undo-block) (replace-node context node quote-node) (replace-node context (subnode 1 quote-node) node) (note-change quote-node context) (select-node context quote-node) (set-point point context quote-node nil t nil (quote structure)) (end-undo-block))) (il:* il:\; "must return non-NIL if command executed") t)
)

(REDISPLAY

  (IL:LAMBDA (CONTEXT)
                              (IL:* IL:\; "Edited  5-Dec-90 14:16 by woz")


(IL:* IL:|;;;| "woz: i don't think this function ever gets called!!!")


    (VERIFY-STRUCTURE CONTEXT NIL NIL T)))

(redo

(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:39 by DCB") (let ((undo-undo-list (il:fetch undo-undo-list il:of context)) (promptwindow (get-prompt-window context))) (cond (undo-undo-list (set-selection-nowhere (il:fetch selection il:of context)) (set-point-nowhere (il:fetch caret-point il:of context)) (undo-event (car undo-undo-list) context) (il:replace undo-undo-list il:of context il:with (cdr undo-undo-list))) (t (il:|printout| promptwindow t "No Undo to Undo")))) t)
)

(selected-fn-name

(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:39 by DCB") (close-open-node context) (or (get-selected-structure context) (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point)) structure) (when (il:type? edit-node node) (il:setq structure (il:fetch structure il:of node)) (when (il:listp structure) (il:setq structure (car structure))) (when (il:atom structure) structure)))))
)

(skip-to-gap

(il:lambda (context) (il:* il:\; "Edited 23-Nov-87 18:19 by DCB") (let ((selection (il:fetch selection il:of context)) (point (il:fetch caret-point il:of context)) (promptwindow (get-prompt-window context)) node) (cond ((il:setq node (il:fetch select-node il:of selection)) (unless (select-next-gap context node (il:fetch select-start il:of selection)) (il:|printout| promptwindow t "No more blanks to fill in."))) ((il:setq node (il:fetch point-node il:of point)) (unless (select-next-gap context node (if (eq (il:fetch point-type il:of point) (quote structure)) (il:fetch point-index il:of point) 0)) (il:|printout| promptwindow t "No more blanks to fill in."))) (t (il:|printout| promptwindow t "Select point from which to start search for blanks.")))) t)
)

(undo

(il:lambda (context) (il:* il:\; "Edited  7-Jul-87 09:39 by DCB") (close-open-node context) (let ((undo-list (il:fetch undo-list il:of context)) (promptwindow (get-prompt-window context))) (cond (undo-list (il:replace undo-list il:of context il:with (il:fetch undo-undo-list il:of context)) (set-selection-nowhere (il:fetch selection il:of context)) (set-point-nowhere (il:fetch caret-point il:of context)) (undo-event (car undo-list) context) (il:replace undo-undo-list il:of context il:with (il:fetch undo-list il:of context)) (when (null (il:replace undo-list il:of context il:with (cdr undo-list))) (il:replace changed-structure? il:of context il:with nil))) (t (il:|printout| promptwindow t (if (il:fetch undo-undo-list il:of context) "Nothing else to Undo" "Nothing to Undo"))))) t)
)

(undo-extract

(il:lambda (context node subnodes) (il:* il:\; "Edited  7-Jul-87 09:39 by DCB") (il:* il:|;;;| "sticks subnodes back into node and revives them.  ") (rplacd (il:fetch sub-nodes il:of node) subnodes) (il:for subnode il:in subnodes il:as index il:from 1 il:do (il:replace super-node il:of subnode il:with node) (il:replace sub-node-index il:of subnode il:with index) (detach-node subnode) (revive-node subnode (il:fetch depth il:of node))) (il:* il:|;;| "used to reparse here.  now if we simply note the change, the format types, format values, and linear forms will be recomputed.") (note-change node context))
)
)
(IL:PUTPROPS IL:SEDIT-COMMANDS IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 2018
 2021))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (13643 14213 (PSEUDO-SELECTION-FROM-SELECTION 13643 . 14213)) (14215 14969 (
COMPOSE-PSEUDO-SELECTION 14215 . 14969)) (14971 15510 (DECOMPOSE-PSEUDO-SELECTION 14971 . 15510)) (
15512 16309 (SELECTION-FROM-PSEUDO-SELECTION 15512 . 16309)) (16311 16614 (SELECT-PSEUDO-SEGMENT 16311
 . 16614)) (16679 17569 (ADD-COMMAND 16679 . 17569)) (17571 19734 (GET-SELECTION 17571 . 19734)) (
19736 20916 (REPLACE-SELECTION 19736 . 20916)) (20918 21410 (RESET-COMMANDS 20918 . 21410)) (21412 
21581 (DEFAULT-COMMANDS 21412 . 21581)) (22059 23162 (EQUALIZE-STRING-WIDTHS 22059 . 23162)) (23164 
23362 (MINIMUM-STRING-WIDTH 23164 . 23362)) (23364 23562 (MAXIMUM-STRING-WIDTH 23364 . 23562)) (23564 
24435 (FIND-AND-DISPLAY-STRUCTURE 23564 . 24435)) (24437 25121 (FIND-AND-DISPLAY-STRUCTURE-BACKWARDS 
24437 . 25121)) (25123 26027 (FIND-AND-DISPLAY-SUBSTRUCTURE 25123 . 26027)) (26029 26732 (
FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS 26029 . 26732)) (26734 27375 (FIND-NTH-STRUCTURE 26734 . 27375
)) (27377 30107 (FIND-NODE-SUBSTRUCTURE 27377 . 30107)) (30109 31362 (FIND-NODE-SUBSTRUCTURE-BACKWARDS
 30109 . 31362)) (31364 32343 (FIND-OBJ 31364 . 32343)) (32345 33745 (FIND-SELECTION 32345 . 33745)) (
33747 35439 (FIND-SELECTION-BACKWARDS 33747 . 35439)) (35441 38170 (FIND-STRUCTURE 35441 . 38170)) (
38172 40519 (FIND-STRUCTURE-BACKWARDS 38172 . 40519)) (40521 43450 (FIND-SUBSTRUCTURE 40521 . 43450)) 
(43452 45752 (FIND-SUBSTRUCTURE-BACKWARDS 43452 . 45752)) (45754 45990 (GET-USER-STRING 45754 . 45990)
) (45992 49700 (SEARCH-OBJ 45992 . 49700)) (49702 53367 (SEARCH-OBJ-BACKWARDS 49702 . 53367)) (53369 
58195 (SUBSTITUTE-OBJ 53369 . 58195)) (58197 62853 (SUBSTITUTE-STRUCTURE 58197 . 62853)) (62855 66027 
(SUBSTITUTE-SUBSTRUCTURE 62855 . 66027)) (66029 67191 (STRUCTURE-FROM-SELECTION 66029 . 67191)) (67193
 68036 (STRUCTURE-FROM-STRING 67193 . 68036)) (68038 70179 (COMMENT-OUT-SELECTION 68038 . 70179)) (
70180 125041 (ADD-MENU 70193 . 70856) (BACKSPACE 70858 . 71837) (CHANGE-PACKAGE 71839 . 74639) (
CHANGE-PRINTBASE 74641 . 76823) (CHANGE-QUOTE 76825 . 77180) (CONVERT-COMMENT 77182 . 78942) (
CONVERT-COMMENT-STRUCTURE 78944 . 80247) (CONVERT-COMMENT-TAIL 80249 . 81649) (CREATE-COMMAND-TABLE 
81651 . 83629) (DEFAULT-EDIT-FN 83631 . 83768) (DELETE-SELECTION 83770 . 84452) (DELETE-WORD 84454 . 
86555) (DO-MUTATION 86557 . 87105) (EDIT-SELECTION 87107 . 87555) (EVAL-SELECTION 87557 . 89426) (
EXPAND 89428 . 90557) (EXTRACT-CURRENT-SELECTION 90559 . 92927) (FIND-COMMENT 92929 . 93623) (GET-MENU
 93625 . 94002) (EDIT-HELP 94004 . 95079) (HELPMENU 95081 . 97870) (INPUT-DOT 97872 . 100004) (
INPUT-ESCAPE 100006 . 100254) (INPUT-NORMAL-CHAR 100256 . 102289) (INPUT-QUOTE 102291 . 105373) (
INPUT-SQUARE-BRACKET 105375 . 105726) (INPUT-STRINGDELIM 105728 . 107127) (INPUT-TOKENDELIM 107129 . 
108109) (INSERT-MULTI-ESCAPE 108111 . 109239) (INSERT-SPECIAL-CHARACTER 109241 . 110501) (
INSPECT-SELECTION 110503 . 111038) (JOIN 111040 . 114710) (MENU-CLOSEFN 114712 . 114930) (
MENU-FIND-SELECTEDFN 114932 . 115632) (MENU-INIT-STATE 115634 . 116441) (MENU-PACKAGE-SELECTEDFN 
116443 . 117494) (MENU-PRINTBASE-SELECTEDFN 117496 . 118372) (MENU-SELECTEDFN 118374 . 118800) (
MENU-SUBSTITUTE-SELECTEDFN 118802 . 119762) (MUTATE 119764 . 120874) (QUOTE-CURRENT-SELECTION 120876
 . 121643) (REDISPLAY 121645 . 121884) (REDO 121886 . 122380) (SELECTED-FN-NAME 122382 . 122827) (
SKIP-TO-GAP 122829 . 123606) (UNDO 123608 . 124408) (UNDO-EXTRACT 124410 . 125039)))))
IL:STOP