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

(IL:FILECREATED " 2-Dec-92 17:28:09" IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>SEDIT-BASE.;7|
 104133 

      IL:|changes| IL:|to:|  (IL:FNS SETUP-WINDOW-AND-PROCESS)

      IL:|previous| IL:|date:| "10-Jul-91 15:05:17" IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>SEDIT-BASE.;6|
)


; Copyright (c) 1987, 1988, 1990, 1991, 1992 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:SEDIT-BASECOMS)

(IL:RPAQQ IL:SEDIT-BASECOMS

          ((IL:PROP IL:FILETYPE IL:SEDIT-BASE)
           (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-BASE)
           (IL:LOCALVARS . T)
           (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS))
           (IL:BITMAPS GAP-BITMAP ARGS-BITMAP BODY-BITMAP)
           (IL:VARIABLES *CLEAR-LINEAR-ON-COMPLETION* *IGNORE-CHANGES-ON-COMPLETION* *COMPILE-FN*)
           (IL:FUNCTIONS COMPLETE THROW-AWAY-CHANGES SET-INITIAL-SELECTION PREV-NODE 
                  MAKE-FUNCTION-PROTOTYPE)
           (IL:P (IL:MOVD 'MAKE-FUNCTION-PROTOTYPE 'XCL::%MAKE-FUNCTION-PROTOTYPE))
           (IL:FNS ADJUST-WIDTH ASSIGN-FORMAT-NIL ATOM-CHANGE-RELINEARIZE BUILD-INTERNAL-STRUCTURE 
                  BUILD-LINEAR-FORM BUILD-NODE BUILD-PRELINEARIZED-NODE CLOSE-NODE COLLECT-UNDO-BLOCK
                  COMPILE-STRUCTURE COMPUTE-ALL-FORMATS COMPUTE-FORMATS-AND-FORMAT-VALUES 
                  COMPUTE-POINT-POSITION COMPUTE-SELECTION-POSITION 
                  COMPUTE-SELECTION-POSITION-DEFAULT CONTAINS? COPY-NODE COPY-SELECTION 
                  COPY-SELECTION-DEFAULT CREATE-CONSTANT-STRINGS CREATE-ENVIRONMENTS CREATE-GAP-NODE
                  CREATE-NODE CREATE-PRELINEARIZED-NODE CREATE-PRETTY-PRINT-ENV CREATE-SIMPLE-NODE 
                  CREATE-STRING-ITEM DEFAULT-COMPILE-FN DEFAULT-GETDEF-FN DEFAULT-PACKAGE 
                  DELETE-NODES DETACH-NODE FORMAT-VALUES-CHANGED GET-SELECTED-STRUCTURE 
                  HANDLE-COMPLETION INITIALIZE INSERT INSERT-CHANGED KILL-NODE LINEARIZE-ROOT 
                  NEXT-NODE NOTE-CHANGE NOTE-CHANGE-FORMAT NOTE-CHANGE-IN-SIMPLE PARSE PARSE--GAP 
                  PARSE--UNKNOWN PARSE-NEW PROPAGATE-WIDTH-CHANGE RECOMPUTE-WIDTH 
                  RELINEARIZE-WHERE-NECESSARY REPLACE-NODE REPLACE-ROOT REVIVE-NODE SEDIT1 
                  SELECT-NEXT-GAP SET-DEPTH SET-FORMAT SETUP-CONTEXT 
                  SETUP-CONTEXT-WINDOW-DEPENDENCIES SETUP-NEW-CONTEXT SETUP-PROFILE 
                  SETUP-WINDOW-AND-PROCESS SETUP-WINDOW-CONTEXT-DEPENDENCIES SHIFT-LINEAR-FORM 
                  STRINGIFY STRINGIFY-GAP SUBNODE-CHANGED SUBNODE-CHANGED-ROOT TYPE-OF-INPUT 
                  UNDO-EVENT UNDO-REPLACE-ROOT UPDATE VERIFY-STRUCTURE WALK-UP-TREE)))

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

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

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

(IL:FILESLOAD IL:SEDIT-DECLS)
)

(IL:RPAQQ GAP-BITMAP
 #*(15 7)@@@@@DD@@BH@OICN@BH@@DD@@@@@)

(IL:RPAQQ ARGS-BITMAP
 #*(42 9)@@AJFHMC@@@@@@BFCABDH@@@ONDDBBBBAOL@@@DDDALA@@@@@@DMDB@I@@@@@@CFDCHF@@@@@@@@@DD@@@@@@@@@@DD@@@@@@@@@@CH@@@@@
)

(IL:RPAQQ BODY-BITMAP
 #*(42 12)@@C@@@F@@@@@@@A@@@B@@@@@@@B@@@B@@@@@@@BHFADHH@@@@@CDIBMDH@@@ONDEADDEAOL@@@DEADHE@@@@@@DIBEJB@@@@@@C@LFLB@@@@@@@@@@@D@@@@@@@@@@AD@@@@@@@@@@AH@@@@
)

(DEFPARAMETER *CLEAR-LINEAR-ON-COMPLETION*
 NIL
   "Completion assumes old linear forms may be garbage.")

(DEFPARAMETER *IGNORE-CHANGES-ON-COMPLETION*
 T
   "If T, markaschangedfn will ignore calls caused by completion of that edit.")

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

(DEFUN COMPLETE
 (CONTEXT CHARCODE REASON COMPILE?)

(IL:* IL:|;;;| "entry point into completing an sedit.  this function is invoked by the completion commands and the closefn and shrinkfn if the sedit is not busy.  REASON specifies how the user wants to complete, one of  :CLOSE,  :SHRINK, :ABORT, or :DONE.  :ABORT means throw away changes, and :DONE means complete and leave the window open.   In order for SEdit to unwind itself properly, all completion must begin in the SEdit process with the window still open, so the closefn and shrinkfn return DON'T if they're running under the mouse, and the window will be closed appropriately here.  COMPILE? is T if keyboard command says to compile.  ")


   (LET ((COMPILE-SUCCEEDED? T)
         (OPTIONS (IL:FETCH
 EDIT-OPTIONS IL:OF
 CONTEXT)))
        (CLOSE-OPEN-NODE CONTEXT)
        (WHEN (EQ REASON :ABORT)
            (UNLESS (IL:MOUSECONFIRM "Click LEFT to ABORT ALL changes." T (GET-PROMPT-WINDOW CONTEXT)
                           )
                   (RETURN-FROM COMPLETE T))

            (IL:* IL:|;;| "IDEALLY: if we're editing an \"expression\" (not a definition), assume editing structure in place (destructively), and so to abort we must undo all the edits.")


            (IL:* IL:|;;| "HOWEVER: since the file manager (editdef, getdef) edits il:fns, il:vars, etc in place, not a definition, to abort on these types we must undo.")


            (IL:* IL:|;;| "FOR NOW (1/13/91) just undo always.  If the edit interface is changed to always edit a copy/definition for any type, then just undo if type=:expression.")


            (DO NIL
                ((NULL (IL:FETCH
 UNDO-LIST IL:OF
 CONTEXT)))
              (UNDO CONTEXT)))
        (HANDLE-COMPLETION
 CONTEXT REASON)
        (WHEN (AND (NOT (EQ REASON :ABORT))
                   (OR COMPILE? (MEMBER :COMPILE-ON-COMPLETION OPTIONS)))
            (SETQ COMPILE-SUCCEEDED? (COMPILE-STRUCTURE
 CONTEXT)))
        (COND
           ((NOT COMPILE-SUCCEEDED?)

            (IL:* IL:|;;| "if the compile failed, don't continue")


            )
           ((OR (EQ REASON :CLOSE)
                (EQ REASON :ABORT)
                (MEMBER :CLOSE-ON-COMPLETION OPTIONS))
            (IL:CLOSEW (IL:|fetch|
 DISPLAY-WINDOW IL:|of|
 CONTEXT))
            (DISINTEGRATE-CONTEXT CONTEXT)
            (IL:DEL.PROCESS (IL:THIS.PROCESS)))
           ((EQ REASON :SHRINK)
            (IL:SHRINKW (IL:|fetch|
 DISPLAY-WINDOW IL:|of|
 CONTEXT))
            (IL:DEL.PROCESS (IL:THIS.PROCESS)))
           ((EQ REASON :DONE)
            (IL:TTY.PROCESS T)))
        T))

(DEFUN THROW-AWAY-CHANGES
 (CONTEXT)
   (IL:REPLACE
 (EDIT-CONTEXT ATOM-STARTED) IL:OF
 CONTEXT IL:WITH
 NIL)
   (IL:REPLACE
 (EDIT-CONTEXT ATOM-STARTED-UNDO-POINTER) IL:OF
 CONTEXT IL:WITH
 NIL)
   (IL:REPLACE
 (EDIT-CONTEXT CHANGED-STRUCTURE?) IL:OF
 CONTEXT IL:WITH
 NIL)
   (IL:REPLACE
 (EDIT-CONTEXT UNDO-LIST) IL:OF
 CONTEXT IL:WITH
 NIL)
   (IL:REPLACE
 (EDIT-CONTEXT UNDO-UNDO-LIST) IL:OF
 CONTEXT IL:WITH
 NIL))

(DEFUN SET-INITIAL-SELECTION
 (CONTEXT)

(IL:* IL:|;;;| "the initial selection was stored by set-props in the find-candidate field, in the form (structure . instance).  Find and select the nth instance of structure, then replace the find candidate with just the structure.  If there is no candidate, select the next gap.")


   (LET ((CANDIDATE (IL:FETCH
 (EDIT-CONTEXT FIND-CANDIDATE) IL:OF
 CONTEXT)))
        (WHEN (CONSP CANDIDATE)
            (SELECTION-DOWN CONTEXT)
            (COND
               (CANDIDATE (FIND-NTH-STRUCTURE CONTEXT NIL (CAR CANDIDATE)
                                 (CDR CANDIDATE))
                      (IL:REPLACE
 (EDIT-CONTEXT FIND-CANDIDATE) IL:OF
 CONTEXT
                         IL:WITH
 (CAR CANDIDATE)))
               (T (SELECT-NEXT-GAP
 CONTEXT (IL:|fetch|
 ROOT IL:|of|
 CONTEXT))))
            (COMPUTE-SELECTION-POSITION
 (IL:|fetch|
 SELECTION IL:|of|
 CONTEXT)
                   CONTEXT)
            (SHOW-CARET CONTEXT)
            (SELECTION-UP CONTEXT))))

(DEFUN PREV-NODE
 (NODE &OPTIONAL INDEX)

(IL:* IL:|;;;| "step to the previous node before this one (in postorder).  if index is a fixp, start with the first subnode before the one with that index.  if it's T, start with the first node before this node.  if it's NIL, start with this node's last subnode")


   (DO* ((SUBNODES (IL:|fetch|
 SUB-NODES IL:|of|
 NODE)
                (IL:|fetch|
 SUB-NODES IL:|of|
 NODE))
         (LASTINDEX (1+ (FIRST SUBNODES))
                (1+ (FIRST SUBNODES)))
         (INDEX (OR INDEX LASTINDEX)))
        ((AND (INTEGERP INDEX)
              (> INDEX 1)
              (<= INDEX LASTINDEX))
         (NTH (1- INDEX)
              SUBNODES))
      (SETF INDEX (IL:|fetch|
 SUB-NODE-INDEX IL:|of|
 NODE))
      (UNLESS (SETF NODE (IL:|fetch|
 SUPER-NODE IL:|of|
 NODE))
             (RETURN NIL))))

(DEFUN MAKE-FUNCTION-PROTOTYPE
 ()
   (DECLARE
 (GLOBAL ARGS-GAP BODY-GAP))
   (IF (EQ (IL:EDITMODE)
           'IL:SEDIT)
       (LIST ARGS-GAP BODY-GAP)
       (LIST (LIST "Arg List")
             "Body")))

(IL:MOVD 'MAKE-FUNCTION-PROTOTYPE 'XCL::%MAKE-FUNCTION-PROTOTYPE)
(IL:DEFINEQ

(adjust-width

(il:lambda (node context new-width) (il:* il:\; "Edited  6-Jul-87 20:48 by DCB") (il:* il:|;;;| "we've made some change to an open node.  adjust the widths and notice the changes") (let ((string-item (car (il:fetch linear-form il:of node)))) (il:replace width il:of string-item il:with new-width) (il:replace inline-width il:of node il:with new-width) (il:replace preferred-width il:of node il:with new-width) (il:replace actual-width il:of node il:with new-width) (il:replace actual-llength il:of node il:with new-width) (when context (cond ((eq (il:fetch node-type il:of node) type-litatom) (note-change node context)) (t (il:replace changed? il:of node il:with t) (note-change (il:fetch super-node il:of node) context))))))
)

(assign-format-nil

(il:lambda (node context format) (il:* il:\; "Edited  6-Jul-87 20:48 by DCB") (il:* il:|;;;| "assigns NIL as the format for each of the subnodes of node.  ") (il:* il:|;;;| "IMPORTANT NOTE: all nonleaf node types (except node types which have only prelinearized subnodes) must have a method which actually resets the format of each of their subnodes.  if they don't care what format type they assign, they should use this method.  (if the subnode format is not actually reset from the unassigned value, the format assigner and width estimator will not be run, with yukky results.)") (il:for subnode il:in (cdr (il:fetch sub-nodes il:of node)) il:do (set-format subnode context nil)))
)

(atom-change-relinearize

(il:lambda (context) (il:* il:\; "Edited 24-Aug-87 16:22 by drc:") (il:* il:|;;;| "a simple method for relinearizing everything when we think display of atoms may have changed, like if we view the structure from a different package.") (il:* il:|;;;| "need to waste cached atom info in point and selection, as well as make sure the structure is intact.") (close-open-node context) (set-point-nowhere (il:|fetch| caret-point il:|of| context)) (set-selection-nowhere (il:|fetch| selection il:|of| context)) (il:* il:|;;;| "recompute widths for the whole tree ") (walk-up-tree (il:fetch root il:of context) context (function (lambda (node context) (if (eq (il:fetch node-type il:of node) type-litatom) (let* ((structure (il:ffetch structure il:of node)) (broken? (il:type? broken-atom structure))) (unless broken? (il:* il:\; "smash new width into real atom nodes") (let* ((string-item (car (il:ffetch linear-form il:of node))) (width (stringwidth structure (il:ffetch font il:of string-item) (not broken?)))) (il:freplace width il:of string-item il:with width) (il:freplace inline-width il:of node il:with width) (il:freplace preferred-width il:of node il:with width) (il:freplace actual-width il:of node il:with width) (il:freplace actual-llength il:of node il:with width)))) (il:* il:|;;| "just call CFV method for other node types") (funcall (il:fetch compute-format-values il:of (il:ffetch node-type il:of node)) node (il:fetch environment il:of context) context (il:ffetch format il:of node))) (il:* il:\; "mark all nodes as changed") (il:freplace changed? il:of node il:with t)))) (relinearize (il:fetch root il:of context) context))
)

(build-internal-structure

  (il:lambda (context)
                              (il:* il:\; "Edited  6-Apr-88 16:25 by woz")


(il:* il:|;;;| "called when setting up a new context.  the structure to parse was stored in the Root field of the context by get.context.  here we grab it and then setup the context for parsing.")


    (let ((structure (il:|fetch|
 root il:|of|
 context))
          (root (il:|create|
 edit-node
                       node-type il:_ type-root
                       depth il:_ 1
                       sub-nodes il:_ (list 0)
                       linear-form il:_ (cons)
                       start-x il:_ 1
                       actual-width il:_ 0))
          (string (il:allocstring 512 nil nil t)))
         (il:|replace|
 root il:|of|
 context il:|with|
 root)
         (il:|replace|
 caret-point il:|of|
 context il:|with|
 (il:|create|
 edit-point)
                )
         (il:|replace|
 selection il:|of|
 context il:|with|
 (il:|create|
 
                                                                              edit-selection))
         (il:|replace|
 current-node il:|of|
 context il:|with|
 root)
         (il:|replace|
 \\x il:|of|
 context il:|with|
 nil)
         (il:|replace|
 open-node il:|of|
 context il:|with|
 nil)
         (il:|replace|
 open-node-info il:|of|
 context
            il:|with|
 (il:|create|
 open-string
                                 buffer-string il:_ string
                                 substring il:_ (il:substring string 1 1)))
         (il:* il:|;;| "now we're ready to build the actual structures.  build SEdit tree; propagate format types and compute space estimates; and compute actual presentation")


         (parse
 structure context)
         (compute-all-formats
 context)
         (build-linear-form
 context))))

(build-linear-form

  (il:lambda (context)
                              (il:* il:\; "Edited  6-Apr-88 16:38 by woz")


    (il:* il:|;;| "help initialize this context by filling in the linear form.  we fill in initial values for a bunch of fields and then call linearize")


    (let ((root (il:|fetch|
 root il:|of|
 context)))
         (il:|replace|
 current-x il:|of|
 context il:|with|
 (il:|fetch|
 start-x
                                                                          il:|of|
 root))
         (il:|replace|
 current-node il:|of|
 context il:|with|
 root)
         (il:|replace|
 last-linearized-sub-node-index il:|of|
 context il:|with|
 0)
         (il:|replace|
 linear-form il:|of|
 root
            il:|with|
 (cons (il:|create|
 line-start
                                       prev-line il:_ nil
                                       node il:_ root
                                       line-skip il:_ 2
                                       line-ascent il:_ 0
                                       line-descent il:_ 0
                                       indent il:_ (il:|fetch|
 start-x il:|of|
 root)
                                       ycoord il:_ 0)
                                (create-weak-link root)))    (il:* il:\; 

                                        "create the initial, unfilled-in linear form for the root.")


         (il:|replace|
 linear-prev il:|of|
 context il:|with|
 (il:|fetch|
 linear-form
                                                                            il:|of|
 root))
         (il:|replace|
 current-line il:|of|
 context il:|with|
 (il:|fetch|
 linear-form
                                                                             il:|of|
 root))
         (il:|replace|
 first-line il:|of|
 root il:|with|
 (car (il:|fetch|
 linear-form
                                                                             il:|of|
 root)))
         (il:|replace|
 linear-pointer il:|of|
 context il:|with|
 (cdr (il:|fetch|

                                                                                  linear-form
                                                                                    il:|of|

                                                                                    root)))
                                                             (il:* il:\; "this must be special: normally linear-pointer at a weak-link means we're done with this node and go up to the super.")


         (il:|replace|
 first-block il:|of|
 context il:|with|
 (il:|create|

                                                                          line-block
                                                                          block-new-x il:_
                                                                          (il:|fetch|
 start-x
                                                                             il:|of|
 root)
                                                                          block-start il:_
                                                                          (il:|fetch|
 linear-form
                                                                             il:|of|
 root)))
         (il:|replace|
 current-block il:|of|
 context il:|with|
 (il:|fetch|
 
                                                                                  first-block
                                                                              il:|of|
 context))
         (il:|replace|
 relinearization-time-stamp il:|of|
 context il:|with|
 0)
         (il:|replace|
 below? il:|of|
 context il:|with|
 'new)
         (linearize (subnode 1 root)
                context
                (il:idifference (il:windowprop (il:|fetch|
 display-window il:|of|
 context)
                                       'il:width)
                       5))                                   (il:* il:\; 

                                              "fix up some of the information recorded in the root")


         (il:|replace|
 line-length il:|of|
 (car (il:|fetch|
 current-line il:|of|

                                                                                     context))
            il:|with|
 (il:|fetch|
 current-x il:|of|
 context))
         (il:|replace|
 actual-llength il:|of|
 root il:|with|
 (il:idifference (

                                                                                        il:|fetch|

                                                                                          current-x
                                                                                            il:|of|

                                                                                            context)
                                                                                (il:|fetch|

                                                                                 start-x il:|of|

                                                                                         root)))
         (il:|replace|
 actual-width il:|of|
 root il:|with|
 (il:idifference (il:|fetch|

                                                                                        actual-width
                                                                                          il:|of|

                                                                                          root)
                                                                              (il:|fetch|
 start-x
                                                                                 il:|of|
 root)))
                                                             (il:* il:\; 

                       "used to replace LastLineLinear of root with (fetch CurrentLine of context)")


         (il:|replace|
 last-line il:|of|
 root il:|with|
 (car (il:|fetch|
 current-line
                                                                            il:|of|
 context)))
                                                             (il:* il:\; 

           "if we haven't finished updating the window, make sure the last line is dumped properly")


         (when (eq (il:|fetch|
 below? il:|of|
 context)
                   'new)
               (repaint-new-line (il:|fetch|
 current-line il:|of|
 context))))))

(build-node

(il:lambda (structure context node-type trust-subnodes) (il:* il:\; "Edited  3-Dec-87 15:47 by DCB") (il:|replace| current-node il:|of| context il:|with| (il:|bind| (tail il:_ (il:|fetch| \\x il:|of| context)) subnodes il:|while| (il:setq subnodes (cdr tail)) il:|do| (when (eq structure (il:|fetch| structure il:|of| (car subnodes))) (cond ((eq node-type (il:|fetch| node-type il:|of| (car subnodes))) (il:* il:|;;| "we can re-use the node") (rplacd tail (cdr subnodes)) (il:|replace| sub-node-index il:|of| (il:setq subnodes (car subnodes)) il:|with| (il:add1 (car (il:setq tail (il:|fetch| sub-nodes il:|of| (il:|fetch| current-node il:|of| context)))))) (when (not trust-subnodes) (il:* il:|;;| "we were just called from parse--comment, damn it!") (il:|replace| \\x il:|of| context il:|with| (il:|fetch| sub-nodes il:|of| subnodes)) (il:|replace| sub-nodes il:|of| subnodes il:|with| (list 0))) (il:nconc1 tail subnodes) (rplaca tail (il:|fetch| sub-node-index il:|of| subnodes)) (return subnodes)) (t (il:* il:|;;| "it's changed type -- make this undoable") (let ((new-node (create-node structure (il:|fetch| current-node il:|of| context) node-type))) (undo-by replace-node new-node (car subnodes)) (il:|replace| \\x il:|of| context il:|with| nil) (return new-node))))) (il:setq tail subnodes) il:|finally| (il:|replace| \\x il:|of| context il:|with| nil) (return (create-node structure (il:|fetch| current-node il:|of| context) node-type)))))
)

(build-prelinearized-node

(il:lambda (structure context node-type string prin-2? font) (il:* il:\; "Edited 19-Aug-87 17:44 by drc:") (il:replace current-node il:of context il:with (il:bind (tail il:_ (il:fetch \\x il:of context)) subnodes il:while (il:setq subnodes (cdr tail)) il:do (when (eq structure (il:|fetch| structure il:|of| (car subnodes))) (cond ((eq node-type (il:fetch node-type il:of (car subnodes))) (il:* il:|;;| "we can re-use the node") (rplacd tail (cdr subnodes)) (il:replace sub-node-index il:of (il:setq subnodes (car subnodes)) il:with (il:add1 (car (il:setq tail (il:fetch sub-nodes il:of (il:fetch current-node il:of context)))))) (il:replace \\x il:of context il:with (il:fetch sub-nodes il:of subnodes)) (il:replace sub-nodes il:of subnodes il:with (list 0)) (il:nconc1 tail subnodes) (rplaca tail (il:fetch sub-node-index il:of subnodes)) (return subnodes)) (t (il:* il:|;;| "it's changed type -- make this undoable") (let ((new-node (create-prelinearized-node structure (il:fetch current-node il:of context) (il:fetch environment il:of context) node-type string prin-2? font))) (undo-by replace-node new-node (car subnodes)) (return new-node))))) (il:setq tail subnodes) il:finally (il:replace \\x il:of context il:with nil) (return (create-prelinearized-node structure (il:fetch current-node il:of context) (il:fetch environment il:of context) node-type string prin-2? font)))))
)

(close-node

(il:lambda (context) (il:* il:\; "Edited  6-Jul-87 20:48 by DCB") (when (il:fetch open-node il:of context) (if (dead-node? (il:fetch open-node il:of context)) (il:replace open-node il:of context il:with nil) (funcall (il:fetch close-node il:of (il:fetch node-type il:of (il:fetch open-node il:of context))) context (il:fetch open-node il:of context)))) (il:replace open-node-changed? il:of context il:with nil))
)

(collect-undo-block

(il:lambda (context) (il:* il:\; "Edited  6-Jul-87 20:48 by DCB") (let ((block-start (il:fetch undo-list il:of context))) (cond ((null block-start) (il:* il:\; "empty undo list -- do nothing") nil) ((null (car block-start)) (il:* il:\; "empty block -- throw it out") (il:replace undo-list il:of context il:with (cdr block-start))) (t (il:for (block-end il:_ block-start) il:by (cdr block-end) il:while (cadr block-end) il:eachtime (when (null (cdr block-end)) (il:* il:\; "no matching blip -- do nothing") (return)) il:finally (cond ((eq block-start block-end) (il:* il:\; "one element block -- just remove the blip") (rplacd block-end (cddr block-end))) (t (il:replace undo-list il:of context il:with (cdr block-end)) (rplacd block-end nil) (rplaca (il:fetch undo-list il:of context) block-start))))))))
)

(COMPILE-STRUCTURE

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


(IL:* IL:|;;;| 

"Compile the function being edited (if any).  Return T if compilation returns OK, NIL otherwise.")


    (LET ((NAME (IL:|fetch|
 ICON-TITLE IL:|of|
 CONTEXT))
          (TYPE (IL:|fetch|
 EDIT-TYPE IL:|of|
 CONTEXT))
          (BODY (IL:|fetch|
 STRUCTURE IL:|of|
 (CADR (IL:|fetch|
 SUB-NODES
                                                               IL:|of|
 (IL:|fetch|
 ROOT
                                                                              IL:|of|
 CONTEXT))))
                )
          (PW (OR (IL:OPENWP (GET-PROMPT-WINDOW CONTEXT))
                  IL:PROMPTWINDOW)))
         (WHEN NAME (FORMAT PW "~%Compiling ~A defn of ~A..." TYPE NAME))
         (COND
            ((IL:ERSETQ (FUNCALL *COMPILE-FN* NAME TYPE BODY))
             (FORMAT PW "~%~A compiled." NAME)
             T)
            (T (FORMAT PW "~%Compilation of ~A failed." NAME)
               NIL)))))

(compute-all-formats

(il:lambda (context) (il:* il:\; "Edited  6-Jul-87 20:48 by DCB") (il:* il:|;;;| "assigns format types to each node in the tree top-down and width estimates to each node bottom-up.  Avoids touching any node more than once and does not record changes.") (il:replace dont-collect-changes? il:of context il:with t) (compute-formats-and-format-values (il:fetch root il:of context) context) (il:replace dont-collect-changes? il:of context il:with nil))
)

(compute-formats-and-format-values

(il:lambda (node context) (il:* il:\; "Edited  6-Jul-87 20:48 by DCB") (il:* il:|;;;| "computes format types and horizontal space estimates for the SEdit subtree rooted at node.  assigns format type from root down, so that a node's format type can be based on the format type of its parent.  computes format values depth first, so that a node's space estimates can be based on those of its children.") (il:* il:|;;;| "efficiency note: if an assign format method changes the format, it will before returning cause the assign format methods of its subnodes to be run.  this means that the assign format method will be run twice for some nodes.") (funcall (il:fetch assign-format il:of (il:fetch node-type il:of node)) node context (il:fetch format il:of node)) (il:for subnode il:in (cdr (il:fetch sub-nodes il:of node)) il:do (compute-formats-and-format-values subnode context)) (funcall (il:fetch compute-format-values il:of (il:fetch node-type il:of node)) node (il:fetch environment il:of context) context (il:fetch format il:of node)))
)

(compute-point-position

(il:lambda (point context) (il:* il:\; "Edited 14-Jan-88 10:40 by DCB") (il:* il:|;;;| "if there's a caret point, compute its coordinates.  each node type has a method for this") (il:* il:|;;| "if we get an error we throw the point away.") (when (il:type? edit-node (il:fetch point-node il:of point)) (if (dead-node? (il:fetch point-node il:of point)) (set-point-nowhere point) (let ((errval (il:nlsetq (funcall (il:fetch compute-point-position il:of (il:fetch node-type il:of (il:fetch point-node il:of point))) point context)))) (unless errval (set-point-nowhere point))))))
)

(compute-selection-position

(il:lambda (selection context) (il:* il:\; "Edited 14-Jan-88 10:42 by DCB") (il:* il:|;;;| "if there's a current selection, compute its coordinates.  each node has a method for this") (il:* il:|;;| "if this errs out we throw away the selection") (when (il:fetch select-node il:of selection) (cond ((dead-node? (il:fetch select-node il:of selection)) (set-selection-nowhere selection)) ((il:fetch select-start il:of selection) (let ((errval (il:nlsetq (funcall (il:fetch compute-selection-position il:of (il:fetch node-type il:of (il:fetch select-node il:of selection))) selection context)))) (unless errval (set-selection-nowhere selection)))) (t (let ((node (il:fetch select-node il:of selection))) (il:replace select-start-x il:of selection il:with (il:fetch start-x il:of node)) (il:replace select-start-line il:of selection il:with (il:fetch first-line il:of node)) (il:replace select-end-x il:of selection il:with (il:iplus (il:fetch start-x il:of node) (il:fetch actual-llength il:of node))) (il:replace select-end-line il:of selection il:with (il:fetch last-line il:of node)))))))
)

(compute-selection-position-default

(il:lambda (selection context) (il:* il:\; "Edited  6-Jul-87 20:48 by DCB") (il:* il:|;;;| "a default ComputeSelectionPosition method for aggregate nodes.  start and end values are assumed to be subnode indices, and the selection will extend from the beginning of the first selected subnode to the end of the last") (let ((start (subnode (il:fetch select-start il:of selection) (il:fetch select-node il:of selection))) end) (il:setq end (if (il:fetch select-end il:of selection) (subnode (il:fetch select-end il:of selection) (il:fetch select-node il:of selection)) start)) (il:replace select-start-x il:of selection il:with (il:fetch start-x il:of start)) (il:replace select-start-line il:of selection il:with (il:fetch first-line il:of start)) (il:replace select-end-x il:of selection il:with (il:iplus (il:fetch start-x il:of end) (il:fetch actual-llength il:of end))) (il:replace select-end-line il:of selection il:with (il:fetch last-line il:of end))))
)

(contains?

(il:lambda (selection-1 selection-2) (il:* il:\; "Edited  6-Jul-87 20:48 by DCB") (il:* il:|;;;| "check to see if the selection overlaps some or all of these nodes.  if there's no overlap, return NIL.  if it properly contains them, return T.  otherwise return (QUOTE Overlap).  (node1, start1, end1) and (node2, start2, end2) describe the two sequences of nodes") (let ((node-1 (il:fetch select-node il:of selection-1)) (start-1 (il:fetch select-start il:of selection-1)) (end-1 (il:fetch select-end il:of selection-1)) (node-2 (il:fetch select-node il:of selection-2)) (start-2 (il:fetch select-start il:of selection-2)) (end-2 (il:fetch select-end il:of selection-2))) (cond ((null start-1) (il:setq start-1 (il:setq end-1 (il:fetch sub-node-index il:of node-1))) (il:setq node-1 (il:fetch super-node il:of node-1))) ((null end-1) (il:setq end-1 start-1))) (cond ((null start-2) (il:setq start-2 (il:setq end-2 (il:fetch sub-node-index il:of node-2))) (il:setq node-2 (il:fetch super-node il:of node-2))) ((null end-2) (il:setq end-2 start-2))) (il:* il:|;;| "now we must get the selections at equal tree depth so we can compare bounds.  First try to bring node2 up to depth of node1, then do it the other way.  It doesn't matter which loop runs, the depths will end up equal.") (il:while (il:ilessp (il:fetch depth il:of node-1) (il:fetch depth il:of node-2)) il:do (il:setq start-2 (il:setq end-2 (il:fetch sub-node-index il:of node-2))) (il:setq node-2 (il:fetch super-node il:of node-2))) (il:* il:|;;| " bring node 1 up to depth of node 2, in case the first loop was wrong") (il:while (il:ilessp (il:fetch depth il:of node-2) (il:fetch depth il:of node-1)) il:do (il:setq start-1 (il:setq end-1 (il:fetch sub-node-index il:of node-1))) (il:setq node-1 (il:fetch super-node il:of node-1))) (il:* il:|;;| "and see if the selection contains the node2 sequence.  ") (cond ((or (il:neq node-1 node-2) (il:ilessp end-1 start-2) (il:ilessp end-2 start-1)) (il:* il:|;;| "non-overlapping sisters") nil) (t (il:* il:|;;| "they do overlap.  check if it's proper, otherwise return Unsafe") (or (and (il:ileq start-1 start-2) (il:igeq end-1 end-2)) (quote overlap))))))
)

(copy-node

  (il:lambda (node context)
                         (il:* il:\; "Edited  6-Apr-88 16:42 by woz")


(il:* il:|;;;| "copy the subtree rooted at node")


    (let ((new-node (il:|create|
 edit-node
                           node-type il:_ (il:|fetch|
 node-type il:|of|
 node)
                           structure il:_ (il:|fetch|
 structure il:|of|
 node)
                           sub-node-index il:_ (il:|fetch|
 sub-node-index il:|of|
 node)
                           changed? il:_ t
                           inline-width il:_ (il:|fetch|
 inline-width il:|of|
 node)
                           preferred-width il:_ (il:|fetch|
 preferred-width il:|of|
 node)
                           unassigned il:_ (il:|fetch|
 unassigned il:|of|
 node))))
         (il:|replace|
 sub-nodes il:|of|
 new-node
            il:|with|
 (cons (car (il:|fetch|
 sub-nodes il:|of|
 node))
                                (il:|for|
 subnode il:|in|
 (cdr (il:|fetch|
 sub-nodes
                                                                          il:|of|
 node))
                                   il:|collect|
 (il:setq subnode (copy-node
 subnode context))
                                         (il:|replace|
 super-node il:|of|
 subnode
                                            il:|with|
 new-node)
                                         subnode)))
         (il:* il:|;;| "if this node type has no relinearization method, copy the linear form")


         (cond
            ((il:|fetch|
 linearize il:|of|
 (il:|fetch|
 node-type il:|of|
 node))
             (il:|replace|
 linear-form il:|of|
 new-node il:|with|
 (create-weak-link
                                                                               new-node)))
            (t (il:|replace|
 linear-form il:|of|
 new-node il:|with|
 (il:append
                                                                                 (il:|fetch|

                                                                                  linear-form
                                                                                    il:|of|

                                                                                    node)
                                                                                 (create-weak-link
                                                                                  new-node)))
               (il:|replace|
 actual-width il:|of|
 new-node il:|with|
 (il:|fetch|

                                                                                  actual-width
                                                                                    il:|of|

                                                                                    node))
               (il:|replace|
 actual-llength il:|of|
 new-node il:|with|
 (il:|fetch|

                                                                                    actual-llength
                                                                                      il:|of|

                                                                                      node))))
         (il:* il:|;;| "the CopyStructure method will fill in the Structure field appropriately")


         (funcall (il:|fetch|
 copy-structure il:|of|
 (il:|fetch|
 node-type il:|of|

                                                                                       node))
                new-node context)
         new-node)))

(copy-selection

(il:lambda (selection context destination-context point delete?) (il:* il:\; "Edited 19-Nov-87 15:45 by DCB") (il:* il:|;;;| "apply CopySelection method for the selected node, to copy or move the current selection") (if (or (null destination-context) (il:fetch point-node il:of point)) (cond ((and destination-context delete? (il:type? edit-selection (il:fetch point-node il:of point)) (contains? (il:fetch point-node il:of point) selection)) (il:* il:|;;| "this is a move selection into an overlapping pending delete selection.  can't handle this case because deleting the selection to move deletes some nodes out from under the pending delete selection, and then the selection is wrong.  if we could fix up the selection in this case (hard) we would be okay.") (il:|printout| (get-prompt-window destination-context) t "Can't move a structure which overlaps the selection.")) (t (when (eq context destination-context) (start-undo-block)) (funcall (il:fetch copy-selection il:of (il:fetch node-type il:of (il:fetch select-node il:of selection))) selection context destination-context point delete?) (when (eq context destination-context) (il:* il:|;;| "if we're moving within the same context, then we want the insert and possible delete to be grouped, so we need to close the node inserted into (so changes will get recorded).  Since we're in the same context, the correct profile closing is the current profile.") (close-open-node context) (end-undo-block)))) (il:|printout| (get-prompt-window context) t "Select a place to " (if delete? "move" "copy") " to.")))
)

(copy-selection-default

(il:lambda (selection context destination point delete?) (il:* il:\; "Edited  6-Jul-87 20:49 by DCB") (il:* il:|;;;| "a simple copy selection method for aggregate nodes") (let ((node (il:fetch select-node il:of selection)) (start (il:fetch select-start il:of selection)) (end (il:fetch select-end il:of selection)) nodes) (cond (destination (il:* il:\; "copying into an SEdit") (with-profile (il:fetch profile il:of destination) (il:setq nodes (if (null start) (list node) (il:for i il:from start il:to (or end start) il:as subnode il:in (il:nth (cdr (il:fetch sub-nodes il:of node)) start) il:collect subnode))) (if (eq (il:fetch point-type il:of point) (quote string)) (il:setq nodes (il:concatlist (cdr (il:for node il:in nodes il:join (list " " (stringify node (il:fetch environment il:of context))))))) (il:setq nodes (il:for node il:in nodes il:collect (copy-node node destination)))) (when delete? (delete-nodes node context start end)) (insert point destination nodes))) ((null start) (il:* il:\; "copying one node to a foreign sink.  just bksysbuf it") (il:bksysbuf (il:fetch structure il:of node) t) (when delete? (delete-nodes (il:fetch super-node il:of node) context node))) (t (il:* il:\; "copying a sequence of nodes to a foreign sink.  bksysbuf each one, with spaces between them") (il:bind blank-before il:for i il:from start il:to (or end start) il:as x il:on (cdr (il:nth (il:fetch sub-nodes il:of node) start)) il:do (if blank-before (il:bksysbuf " ") (il:setq blank-before t)) (il:bksysbuf (il:fetch structure il:of (car x)) t)) (when delete? (delete-nodes node context start end))))))
)

(create-constant-strings

(il:lambda (env) (il:* il:\; "Edited 23-Feb-88 11:09 by raf") (let ((font (il:fetch default-font il:of env))) (il:replace lparen-string il:of env il:with (create-string-item "(" font)) (il:replace rparen-string il:of env il:with (create-string-item ")" font)) (il:replace dot-string il:of env il:with (create-string-item "." font)) (il:replace quote-string il:of env il:with (il:for prefix il:in (quote ((quote . "'") (il:bquote . "`") (il:comma . ",") (comma-at . ",@") (comma-dot . ",.") (function . "#'"))) il:join (list (car prefix) (create-string-item (cdr prefix) font)))) (il:replace comment-string il:of env il:with (il:for prefix il:in (quote ((1 . "; ") (2 . ";; ") (3 . ";;; ") (4 . ";;;; ") (5 . "#|") (6 . "|#"))) il:join (list (car prefix) (create-string-item (cdr prefix) (il:fetch keyword-font il:of env)))))))
)

(CREATE-ENVIRONMENTS

  (IL:LAMBDA NIL
                                    (IL:* IL:\; "Edited 10-Jul-91 15:02 by jds")


(IL:* IL:|;;;| "remake lisp environment based on fonts, command table spec... now this guy only makes the lisp edit environment.  the pretty print environment is created when it is needed, because otherwise it makes lots of IP fonts that the user doesn't need/have.  pretty.print calls create.pretty.print.env to create it when necessary.")


    (LET ((COMMANDS (CREATE-COMMAND-TABLE COMMAND-TABLE-SPEC)))
         (IL:SETQ LISP-EDIT-ENVIRONMENT (IL:CREATE
 EDIT-ENV
                                               PARSE-INFO IL:_ (LIST 'IL:LITATOM 'PARSE--LITATOM
                                                                     'IL:SMALLP
                                                                     'PARSE--LITATOM
                                                                     'IL:STRINGP
                                                                     'PARSE--STRING
                                                                     'IL:LISTP
                                                                     'PARSE--LIST
                                                                     'IL:FIXP
                                                                     'PARSE--LITATOM
                                                                     'BIGNUM
                                                                     'PARSE--LITATOM
                                                                     'IL:FLOATP
                                                                     'PARSE--LITATOM
                                                                     'RATIO
                                                                     'PARSE--LITATOM
                                                                     'IL:CHARACTER
                                                                     'PARSE--LITATOM
                                                                     'GAP
                                                                     'PARSE--GAP
                                                                     'BROKEN-ATOM
                                                                     'PARSE--BROKEN-ATOM
                                                                     'IL:NEW-ATOM
                                                                     'PARSE--LITATOM)
                                               PARSE-INFO-UNKNOWN IL:_ 'PARSE--UNKNOWN
                                               DEFAULT-FONT IL:_ (IL:FONTCREATE IL:DEFAULTFONT)
                                               ITALIC-FONT IL:_ (IL:FONTCREATE IL:ITALICFONT)
                                               KEYWORD-FONT IL:_ (IL:FONTCREATE IL:CLISPFONT)
                                               COMMENT-FONT IL:_ (IL:FONTCREATE IL:COMMENTFONT)
                                               BROKEN-ATOM-FONT IL:_ (IL:FONTCREATE IL:ITALICFONT)
                                               SPACE-WIDTH IL:_ (IL:CHARWIDTH (IL:CHARCODE IL:SPACE)
                                                                       (IL:FONTCREATE IL:DEFAULTFONT)
                                                                       )
                                               DEFAULT-LINE-SKIP IL:_ 2
                                               COMMAND-TABLE IL:_ (CAR COMMANDS)
                                               HELP-MENU IL:_ (CADR COMMANDS)
                                               DEFAULT-CHAR-HANDLER IL:_ (IL:FUNCTION 
                                                                          INPUT-NORMAL-CHAR)
                                               EM-WIDTH IL:_ (IL:CHARWIDTH (IL:CHARCODE "M")
                                                                    (IL:FONTCREATE IL:DEFAULTFONT))
                                               INDENT-BASE IL:_ (IL:CHARWIDTH (IL:CHARCODE "M")
                                                                       (IL:FONTCREATE IL:DEFAULTFONT)
                                                                       )
                                               INDENT-STEP IL:_ (IL:ITIMES 2 (IL:CHARWIDTH
                                                                              (IL:CHARCODE "M")
                                                                              (IL:FONTCREATE 
                                                                                     IL:DEFAULTFONT))
                                                                       )
                                               MAX-WIDTH IL:_ 500
                                               COMMENT-WIDTH-PERCENT IL:_ 40
                                               INIT-COMMENT-SEPARATION IL:_ 15))
         (CREATE-CONSTANT-STRINGS
 LISP-EDIT-ENVIRONMENT))))

(create-gap-node

  (il:lambda (gap)
                                  (il:* il:\; "Edited  6-Apr-88 16:43 by woz")


    (let* ((width (linear-item-width (il:|fetch|
 linear-item il:|of|
 gap)))
           (gap-node (il:|create|
 edit-node
                            node-type il:_ type-gap
                            structure il:_ gap
                            sub-nodes il:_ (list 0)
                            inline-width il:_ width
                            preferred-width il:_ width
                            actual-llength il:_ width
                            actual-width il:_ width)))
          (il:|replace|
 linear-form il:|of|
 gap-node il:|with|
 (cons (il:|fetch|

                                                                                  linear-item
                                                                                    il:|of|

                                                                                    gap)
                                                                                 (create-weak-link
                                                                                  gap-node)))
          gap-node)))

(create-node

  (il:lambda (structure super-node nodetype)
        (il:* il:\; "Edited  6-Apr-88 16:44 by woz")


(il:* il:|;;;| "construct a new node and fit it into the tree")


    (let ((new-node (il:|create|
 edit-node
                           node-type il:_ nodetype
                           super-node il:_ super-node
                           structure il:_ structure
                           sub-nodes il:_ (list 0))))
         (cond
            (super-node (il:|replace|
 depth il:|of|
 new-node
                           il:|with|
 (il:add1 (il:|fetch|
 depth il:|of|
 super-node)))
                   (il:|replace|
 sub-node-index il:|of|
 new-node
                      il:|with|
 (il:add1 (car (il:|fetch|
 sub-nodes il:|of|
 super-node)))
                          )
                   (il:nconc1 (il:|fetch|
 sub-nodes il:|of|
 super-node)
                          new-node)
                   (rplaca (il:|fetch|
 sub-nodes il:|of|
 super-node)
                          (il:|fetch|
 sub-node-index il:|of|
 new-node)))
            (t (il:|replace|
 depth il:|of|
 new-node il:|with|
 0)))
         (il:|replace|
 linear-form il:|of|
 new-node il:|with|
 (create-weak-link new-node)
                )
         new-node)))

(create-prelinearized-node

(il:lambda (structure super-node environment nodetype string prin-2? font) (il:* il:\; "Edited 17-Nov-87 11:17 by DCB") (il:* il:|;;;| "construct a new node and fit it into the tree.  this node has a fixed linear form, given by string, prin2?  and font, so use create.simple.node to construct it") (let ((new-node (create-simple-node structure environment nodetype string prin-2? font))) (cond ((il:replace super-node il:of new-node il:with super-node) (il:replace depth il:of new-node il:with (il:add1 (il:fetch depth il:of super-node))) (il:replace sub-node-index il:of new-node il:with (il:add1 (car (il:fetch sub-nodes il:of super-node)))) (rplaca (il:fetch sub-nodes il:of super-node) (il:fetch sub-node-index il:of new-node)) (il:nconc1 (il:fetch sub-nodes il:of super-node) new-node)) (t (il:replace depth il:of new-node il:with 0))) new-node))
)

(create-pretty-print-env

(il:lambda nil (il:* il:\; "Edited  6-Jul-87 20:49 by DCB") (il:setq pretty-print-env (il:create edit-env il:using lisp-edit-environment default-font il:_ (il:fontcreate il:defaultfont nil nil nil (quote il:interpress)) italic-font il:_ (il:fontcreate il:italicfont nil nil nil (quote il:interpress)) keyword-font il:_ (il:fontcreate il:clispfont nil nil nil (quote il:interpress)) comment-font il:_ (il:fontcreate il:commentfont nil nil nil (quote il:interpress)) broken-atom-font il:_ (il:fontcreate il:italicfont nil nil nil (quote il:interpress)) space-width il:_ (il:charwidth (il:charcode il:space) (il:fontcreate il:defaultfont nil nil nil (quote il:interpress))) default-line-skip il:_ 0 indent-base il:_ (il:fixr (il:times il:micasperpt (il:fetch indent-base il:of lisp-edit-environment))) indent-step il:_ (il:fixr (il:times il:micasperpt (il:fetch indent-step il:of lisp-edit-environment))) em-width il:_ (il:fixr (il:times il:micasperpt (il:fetch em-width il:of lisp-edit-environment))) max-width il:_ (il:fixr (il:times il:micasperpt (il:fetch max-width il:of lisp-edit-environment))))) (create-constant-strings pretty-print-env))
)

(create-simple-node

  (il:lambda (structure environment nodetype string prin-2? font)

                                                        (il:* il:\; "Edited  6-Apr-88 16:44 by woz")


(il:* il:|;;;| "construct a node with fixed linear form, given by string, prin2?  and font.")


    (let ((width (stringwidth string font prin-2?))
          new-node)
         (il:setq new-node (il:|create|
 edit-node
                                  node-type il:_ nodetype
                                  structure il:_ structure
                                  sub-nodes il:_ (list 0)
                                  inline-width il:_ width
                                  preferred-width il:_ width
                                  actual-width il:_ width
                                  actual-llength il:_ width))
         (il:|replace|
 linear-form il:|of|
 new-node
            il:|with|
 (cons (il:|create|
 string-item
                                       string il:_ string
                                       width il:_ width
                                       font il:_ font
                                       prin-2? il:_ prin-2?)
                                (create-weak-link new-node)))
         new-node)))

(create-string-item

(il:lambda (string font) (il:* il:\; "Edited  6-Jul-87 20:49 by DCB") (il:create string-item string il:_ string width il:_ (stringwidth string font) font il:_ font prin-2? il:_ nil))
)

(default-compile-fn

(il:lambda (name type body) (il:* il:\; "Edited 31-Aug-87 11:59 by drc:") (case type ((il:fns) (compile name body)) (t (compile-form body))))
)

(default-getdef-fn

(il:lambda (name type old-def) (il:* il:\; "Edited 26-Aug-87 10:09 by drc:") (let ((new-def (il:getdef name type nil (quote (il:noerror))))) (or new-def (progn (cerror "Use the definition currently being edited." "No ~S definition for ~S" type name) old-def))))
)

(default-package

(il:lambda (name type structure) (il:* il:\; "Edited 25-Aug-87 17:29 by drc:") (il:* il:|;;;| "called by SETUP-PROFILE to determine what package to use for the edit") (il:* il:|;;;| "We only look at name for now.") (if (and name (symbolp name) (not (keywordp name))) (symbol-package name) *package*))
)

(delete-nodes

(il:lambda (node context start end set-point? string) (il:* il:\; "Edited 17-Nov-87 11:18 by DCB") (il:* il:|;;| "delete a node or sequence of nodes.  if SET-POINT?, change the caret point to be in the gap.  the deletion is handled by the super of the nodes to be deleted.") (if start (funcall (il:fetch delete il:of (il:fetch node-type il:of node)) node context start end set-point? string) (funcall (il:fetch delete il:of (il:fetch node-type il:of (il:fetch super-node il:of node))) (il:fetch super-node il:of node) context node nil set-point?)))
)

(detach-node

(il:lambda (node) (il:* il:\; "Edited 17-Nov-87 11:18 by DCB") (il:* il:|;;;| "sever any connection between node and its old supernode, before it's inserted somewhere else") (il:replace linear-thread il:of node il:with nil))
)

(format-values-changed

(il:lambda (node context) (il:* il:\; "Edited  6-Jul-87 20:49 by DCB") (il:* il:|;;;| "recompute this nodes's width estimates, and check if any have changed") (il:* il:|;;;| "if it's a litatom, we've been updating its width as we go along, so we can safely assume that it's changed.  we won't call cfv.litatom if the node's still open and has been changed.") (cond ((eq (il:fetch node-type il:of node) type-litatom) (when (not (and (eq node (il:fetch open-node il:of context)) (il:fetch open-node-changed? il:of context))) (funcall (il:fetch compute-format-values il:of (il:fetch node-type il:of node)) node (il:fetch environment il:of context) context (il:fetch format il:of node))) t) (t (let ((old-inline-width (il:fetch inline-width il:of node)) (old-preferred-width (il:fetch preferred-width il:of node))) (funcall (il:fetch compute-format-values il:of (il:fetch node-type il:of node)) node (il:fetch environment il:of context) context (il:fetch format il:of node)) (or (il:neq old-inline-width (il:fetch inline-width il:of node)) (il:neq old-preferred-width (il:fetch preferred-width il:of node)))))))
)

(get-selected-structure

(il:lambda (context) (il:* il:\; "Edited  6-Jul-87 20:49 by DCB") (il:* il:|;;;| "this is the guy who figures out what is selected for operations like eval and open.  for now we only want to deal with single selection, not extended ones.  Return NIL if it is an extended selection, or if there is no node selected.") (close-open-node context) (let* ((selection (il:fetch selection il:of context)) (node (il:fetch select-node il:of selection))) (and node (not (il:fetch select-start il:of selection)) (il:fetch structure il:of node))))
)

(HANDLE-COMPLETION

  (IL:LAMBDA (CONTEXT REASON)
                       (IL:* IL:\; "Edited 25-Jan-91 13:52 by woz")


(IL:* IL:|;;;| "call the completion function.  it is either a function or a list of the form (<fn> <extra args>*).  The REASON arg will be :ABORT if the edit completes with an abort command, otherwise it is meaningless. The function is applied to  CONTEXT, STRUCTURE, REASON, <extra args>, where STRUCTURE is the edited structure and REASON is NIL if no changes were made, T if changes were made, and :ABORT is user wants to abort changes.  ")


(IL:* IL:|;;;| "IDEALLY: The completion fn is called in the abort case with the structure including the changes, so that the edit interface could potentially implement \"undo abort\".  But FOR NOW (1/13/91) this doesn't happen (see COMPLETE) because the changes have been undone by the time we get here.")


    (UNLESS (EQ REASON :ABORT)
        (SETQ REASON (IL:|fetch|
 CHANGED-STRUCTURE? IL:|of|
 CONTEXT)))
    (THROW-AWAY-CHANGES CONTEXT)                             (IL:* IL:\; "do this before completion-fn runs, so if markaschanged gets called, it won't think they're still changes on this edit.")

    (LET ((FN (IL:|fetch|
 COMPLETION-FN IL:|of|
 CONTEXT))
          EXTRA-ARGS)
         (WHEN FN
             (WHEN (AND (LISTP FN)
                        (NOT (MEMBER (FIRST FN)
                                    '(LAMBDA IL:LAMBDA))))

                 (IL:* IL:|;;| "catch the #' case by checking for lambda as the car.  This is terrible, but cl:functionp returns T for any list, which is wrong, so can't use it now.")


                 (SETQ EXTRA-ARGS (REST FN))
                 (SETQ FN (FIRST FN)))
             (APPLY FN (LIST* CONTEXT (IL:|fetch|
 STRUCTURE IL:|of|
 (SUBNODE 1
                                                                                   (IL:|fetch|

                                                                                    ROOT IL:|of|

                                                                                         CONTEXT)))
                              REASON EXTRA-ARGS))))))

(initialize

(il:lambda nil (il:* il:\; "Edited 16-Jul-87 15:26 by DCB") (il:pushnew il:markaschangedfns (il:function markaschangedfn)) (il:changename (quote il:editferror) (quote il:copy) (quote new-function-body)) (il:* il:\; "set up SEdit's global variables: the standard environments, node types, and terminal table") (create-environments) (il:setq types (list (il:setq type-root (il:create edit-node-type name il:_ (quote root) assign-format il:_ (quote assign-format-nil) compute-format-values il:_ (quote il:nill) linearize il:_ (quote linearize-root) sub-node-changed il:_ (quote subnode-changed-root) compute-point-position il:_ (quote il:shouldnt) compute-selection-position il:_ (quote compute-selection-position-default) set-point il:_ (quote set-point-nowhere) set-selection il:_ (quote set-selection-nowhere) grow-selection il:_ (quote il:shouldnt) select-segment il:_ (quote select-segment-default) insert il:_ (quote replace-root) delete il:_ (quote il:nill) copy-structure il:_ (quote il:shouldnt) copy-selection il:_ (quote copy-selection-default) back-space il:_ (quote il:shouldnt))) (il:setq type-unknown (il:create edit-node-type name il:_ (quote unknown) assign-format il:_ (quote assign-format-nil) compute-format-values il:_ (quote il:nill) linearize il:_ nil sub-node-changed il:_ (quote il:shouldnt) compute-point-position il:_ (quote il:shouldnt) compute-selection-position il:_ (quote il:shouldnt) set-point il:_ (quote set-point-unknown) set-selection il:_ (quote set-selection-me) grow-selection il:_ (quote grow-selection-default) select-segment il:_ (quote il:shouldnt) insert il:_ (quote il:shouldnt) delete il:_ (quote il:shouldnt) copy-structure il:_ (quote il:nill) copy-selection il:_ (quote copy-selection-default) stringify il:_ (quote stringify-atom) back-space il:_ (quote backspace-unknown))) (il:setq type-gap (il:create edit-node-type il:using type-unknown name il:_ (quote gap) stringify il:_ (quote stringify-gap) back-space il:_ (quote backspace-gap))))) (il:* il:\; "these must be called after types has been created") (initialize-atomic) (initialize-lists) (initialize-comments) (il:setq terminal-table (il:copytermtable)) (il:for class il:in (quote (il:chardelete il:linedelete il:worddelete il:retype il:ctrlv il:eol)) il:do (il:for c il:in (il:getsyntax class terminal-table) il:do (il:setsyntax c (quote il:none) terminal-table))) (il:echomode nil terminal-table) (il:control t terminal-table) (il:setq basic-gap (il:create gap linear-item il:_ (cons 0 gap-bitmap))) (il:setq args-gap (il:create gap linear-item il:_ (cons 3 args-bitmap))) (il:setq body-gap (il:create gap linear-item il:_ (cons 3 body-bitmap))) (il:* il:|;;| "initialize the selection state variables that used to be in the WINDOW file") (il:setq pending-selection (il:create edit-selection)) (il:setq initial-selection (il:create edit-selection)) (il:setq scratch-selection (il:create edit-selection)) (il:setq pending-caret (il:create edit-point)) (il:setq selection-pending? nil) (il:* il:|;;| "initialize the cache point and selection for replace.node") (il:setq temp-point (il:create edit-point)) (il:setq temp-selection (il:create edit-selection)) t)
)

(insert

(il:lambda (point context subnodes) (il:* il:\; "Edited 13-Jan-88 14:46 by DCB") (il:* il:|;;;| "insert handles a lot of different cases, translating where necessary to those handled by the method.  point is a normal point or points to a pending-delete selection. subnodes is a character or string of characters to be inserted, or a list of subnodes, or NIL (split).  we massage the material to be inserted according to the type of point.  methods called to insert a list of subnodes return the list starting with the last subnode inserted, and we automatically fix up the point and handle the uninserted nodes (if any).") (let ((node (il:fetch point-node il:of point)) (selection (il:fetch selection il:of context)) chars where pending-delete?) (when (eq (il:fetch point-type il:of point) (quote structure)) (close-open-node context)) (cond ((il:type? edit-node node) (il:setq where point)) (t (il:* il:|;;| "the pending-delete case.  the PointNode actually points to a selection framing the material to be replaced") (il:setq pending-delete? t) (il:setq node (il:fetch select-node il:of selection)) (cond ((il:fetch select-start il:of selection) (il:setq where selection)) (t (il:setq where node) (il:setq node (il:fetch super-node il:of node)))))) (when node (when (il:type? edit-node subnodes) (il:* il:|;;| "coerce a single node to a list containing that node") (il:setq subnodes (list subnodes))) (il:* il:|;;| "make sure these nodes have been properly disconnected from whence they came") (when (il:listp subnodes) (il:for subnode il:in subnodes il:do (detach-node subnode))) (cond ((eq (il:fetch point-type il:of point) (quote structure)) (il:* il:|;;| "inserting/replacing at a structure point.  inserting NIL does nothing, replacing with it deletes.  if subnodes is a string, the appropriate atom is constructed.  use the value returned by the method to set the point and try again with any leftovers") (cond ((null subnodes) (when pending-delete? (delete-nodes node context (il:fetch select-start il:of selection) (il:fetch select-end il:of selection) point))) ((il:nlistp subnodes) (il:* il:|;;| "insert the atom NIL, and then replace its characters with the character typed") (let ((new-node (create-simple-node nil (il:fetch environment il:of context) type-litatom nil t (il:fetch default-font il:of (il:fetch environment il:of context))))) (funcall (il:fetch insert il:of (il:fetch node-type il:of node)) node context where (list new-node) point) (il:* il:|;;| "this is a little nasty -- we don't want to bother figuring out the printname of the node, so we tell replace.char it was \"\".  but before we do that, we've got to make the inlinewidth agree so that when replace.chars adjusts it it comes out right") (il:replace inline-width il:of new-node il:with 0) (replace-string new-node context 1 0 (or (il:stringp subnodes) (translate-chars (il:mkstring subnodes) (quote atom) (eq *print-case* (quote :upcase)))) point "" (quote atom)))) (t (il:* il:|;;| "keep trying to insert these nodes and placing the point after them until we run out of nodes or run out of places to put them") (il:do (il:setq subnodes (funcall (il:fetch insert il:of (il:fetch node-type il:of node)) node context where subnodes point)) il:repeatwhile (and (setq node (il:fetch point-node il:of (setq where point))) subnodes))))) (t (il:* il:|;;| "inserting/replacing at an atom or string point.  if it's characters, insert them;  otherwise split, and if there were any subnodes insert them") (funcall (il:fetch insert il:of (il:fetch node-type il:of node)) node context where (and (il:nlistp subnodes) subnodes) point) (when (and (il:listp subnodes) (il:fetch point-node il:of point)) (insert point context subnodes)))) (il:* il:|;;| "the copy selection methods rely on there being no selection after an insert.  the copy selection methods can't take care of this because sometimes the selection gets set (eg from moving out of a quote.") (set-selection-nowhere selection))))
)

(insert-changed

(il:lambda (node list) (il:* il:\; "Edited  6-Jul-87 20:50 by DCB") (il:* il:|;;;| "inserts node into list (but not before the first element) such that list is kept in decreasing order of depth") (il:bind next (depth il:_ (il:fetch depth il:of node)) il:while (and (il:setq next (cdr list)) (il:igreaterp (il:fetch depth il:of (car next)) depth)) il:do (il:setq list next) il:finally (rplacd list (cons node next))))
)

(kill-node

(il:lambda (node) (il:* il:\; "Edited 17-Nov-87 11:18 by DCB") (il:* il:|;;;| "the subtree rooted at this node is being deleted.  mark all the nodes as dead, and cut the first line/last line pointers to avoid confusion.") (il:replace depth il:of node il:with 0) (il:replace first-line il:of node il:with nil) (il:* il:|;;| "used to replace LastLineLinear of node with NIL") (il:replace last-line il:of node il:with nil) (il:replace start-x il:of node il:with 0) (il:replace linear-thread il:of node il:with nil) (il:for x il:in (cdr (il:fetch sub-nodes il:of node)) il:do (kill-node x)))
)

(linearize-root

(il:lambda (node context index) (il:* il:\; "Edited  6-Jul-87 20:50 by DCB") (if index (il:shouldnt "can't be within the root node") (linearize (subnode 1 node) context)))
)

(next-node

(il:lambda (node index postorder?) (il:* il:\; "Edited 11-Dec-87 11:38 by DCB") (il:* il:|;;;| "step to the next node after this one (in preorder unless postorder? given).  if index is a fixp, start with the next subnode after the one with that index.  if it's T, start with the first node after this node.  if it's NIL, start with this node's first subnode") (or (and (null index) (subnode 1 node)) (il:first (or index (il:setq index 0)) il:do (when (and (il:fixp index) (il:ilessp index (car (il:fetch sub-nodes il:of node)))) (return (subnode (il:add1 index) node))) (when (and postorder?)) (il:setq index (il:fetch sub-node-index il:of node)) (il:setq node (il:fetch super-node il:of node)) il:repeatwhile node)))
)

(note-change

(il:lambda (node context) (il:* il:\; "Edited  6-Jul-87 20:50 by DCB") (il:* il:|;;;| "this routine should be called whenever we make a structural change to node.  clobber any clisp translation, and insert it into the ChangedNodes list.  the ChangedNodes list is kept sorted by increasing depth.  this is because the ChangedNodes list will next be used to recompute format types, which must be propagated top-down.  ") (when (not (il:fetch changed? il:of node)) (il:for (super il:_ node) il:by (il:fetch super-node il:of super) il:while super il:when (il:listp (il:fetch structure il:of super)) il:do (zap-clisp-translation (il:fetch structure il:of super))) (il:replace changed? il:of node il:with t) (when (not (il:fetch dont-collect-changes? il:of context)) (insert-changed node (il:fetch changed-nodes il:of context))) (il:replace changed-structure? il:of context il:with t)))
)

(note-change-format

(il:lambda (node context) (il:* il:\; "Edited  6-Jul-87 20:50 by DCB") (il:* il:|;;;| "this routine should be called whenever we make a node's format changes.  inserts the node should be inserted in the ChangedNodes list.  this list will include nodes whose structure has changed and nodes whose format type has changed.  it is kept sorted by decreasing depth.  this is because the ChangedFormatNodes list will next be used to recompute width estimates, which must be propagated bottom-up.  ") (il:* il:|;;;| "note that the ChangedNodes list should initially contain the reverse of the old ChangedNodes list (as left behind after noting all structure changes).") (when (not (il:fetch changed? il:of node)) (il:replace changed? il:of node il:with t) (when (not (il:fetch dont-collect-changes? il:of context)) (insert-changed node (il:fetch changed-nodes il:of context)))))
)

(note-change-in-simple

(il:lambda (node context offset width start end) (il:* il:\; "Edited  6-Jul-87 20:50 by DCB") (il:* il:|;;;| "we've changed a prelinearized node.  fix up the linear form and width estimates, and notify its super") (let ((temp (car (il:fetch linear-form il:of node))) new-width) (il:replace string il:of temp il:with (il:fetch structure il:of node)) (il:* il:\; "read table specific") (il:setq new-width (stringwidth (il:fetch string il:of temp) (il:fetch font il:of temp) (il:fetch prin-2? il:of temp))) (il:replace width il:of temp il:with new-width) (il:replace inline-width il:of node il:with new-width) (il:replace preferred-width il:of node il:with new-width) (il:replace actual-width il:of node il:with new-width) (il:replace actual-llength il:of node il:with new-width) (il:replace changed? il:of node il:with t) (note-change (il:fetch super-node il:of node) context)))
)

(parse

  (il:lambda (structure context parser data)
   (il:* il:\; "Edited 22-Jun-90 10:37 by narusawa")


(il:* il:|;;;| "construct the SEdit tree for this structure.  ")


(il:* il:|;;;| "if a node needs to be parsed as a particular kind of structure (for example, the second child of a lambda-list must be parsed as a list, even if it is NIL), you can specify a particular parsing function.")


(il:* il:|;;;| "parse used to compute the width estimates, but it can no longer do that because the new assign format pass must intervene between parsing and computing width estimates, and the assign format pass, since it is top down, and you can't run it until the lower nodes have been created, cannot conveniently be intermingled with the parsing pass.")


    (let ((super-node (il:|fetch|
 current-node il:|of|
 context))
          (environment (il:|fetch|
 environment il:|of|
 context))
          (reuse-nodes (il:|fetch|
 \\x il:|of|
 context))
          this-node)
         (funcall (or parser (il:listget (il:|fetch|
 parse-info il:|of|
 environment)
                                    (il:typename structure))
                      (il:fetch
 parse-info-unknown il:of
 environment))
                structure context data)
         (il:setq this-node (il:|fetch|
 current-node il:|of|
 context))
         (when (cdr (il:|fetch|
 \\x il:|of|
 context))

             (il:* il:|;;| "some of the old nodes weren't reused (ie deleted).  so mark this node changed, and kill the old ones.")


             (il:|replace|
 changed? il:|of|
 this-node il:|with|
 t)
             (kill-node
 (cadr (il:|fetch|
 \\x il:|of|
 context))))
         (when (or (il:|fetch|
 changed? il:|of|
 this-node)
                   (and (eq (il:|fetch|
 start-x il:|of|
 this-node)
                            0)
                        reuse-nodes))

             (il:* il:|;;| "or first case: this node was reused and it changed")


             (il:* il:|;;| "or second case: this node is new but our super node is being reused")


             (il:* il:|;;| " in either case the super-node has changed")


             (il:|replace|
 changed? il:|of|
 super-node il:|with|
 t))
         (il:|replace|
 \\x il:|of|
 context il:|with|
 reuse-nodes)
         (if super-node
             (il:|replace|
 current-node il:|of|
 context il:|with|
 super-node)
             (il:fetch
 current-node il:of
 context)))))

(parse--gap

  (il:lambda (structure context)
                    (il:* il:\; "Edited  6-Apr-88 16:45 by woz")


(il:* il:|;;;| "parse a gap structure (presumably left there by a previous editing session)")


    (build-node
 structure context type-gap)
    (let ((new-node (il:|fetch|
 current-node il:|of|
 context))
          (width (linear-item-width (il:|fetch|
 linear-item il:|of|
 structure))))
         (il:|replace|
 linear-form il:|of|
 new-node il:|with|
 (cons (il:|fetch|

                                                                                 linear-item
                                                                                   il:|of|
 
                                                                                         structure)
                                                                                (create-weak-link
                                                                                 new-node)))
         (il:|replace|
 inline-width il:|of|
 new-node il:|with|
 width)
         (il:|replace|
 preferred-width il:|of|
 new-node il:|with|
 width)
         (il:|replace|
 actual-width il:|of|
 new-node il:|with|
 width)
         (il:|replace|
 actual-llength il:|of|
 new-node il:|with|
 width))))

(parse--unknown

  (il:lambda (structure context)
                   (il:* il:\; "Edited 23-Jun-88 12:42 by Snow")


    (il:* il:|;;| "this is the default parser for structures of an unknown type.  they display in italics, and can't be edited")


    (build-prelinearized-node
 structure context type-unknown structure t
           (il:|fetch|
 comment-font il:|of|
 (il:|fetch|
 environment il:|of|
 context))
           )))

(parse-new

(il:lambda (expression context) (il:* il:\; "Edited  6-Jul-87 20:50 by DCB") (il:replace current-node il:of context il:with nil) (il:replace \\x il:of context il:with nil) (parse expression context))
)

(propagate-width-change

(il:lambda (context node old-width) (il:* il:\; "Edited 17-Nov-87 11:19 by DCB") (il:* il:|;;;| "the width of node has been recomputed.  this may change the width of some of its super nodes, and possibly even the extent recorded with the window") (let ((width (il:fetch actual-width il:of node)) (super (il:fetch super-node il:of node)) super-width new-width) (cond ((eq width old-width) nil) ((null super) (il:replace il:width il:of (il:windowprop (il:fetch display-window il:of context) (quote il:extent)) il:with width)) ((il:fetch super-node il:of super) (il:setq super-width (il:fetch actual-width il:of super)) (il:setq new-width (il:iplus width (il:idifference (il:fetch start-x il:of node) (il:fetch start-x il:of super)))) (cond ((il:igeq new-width super-width) (il:replace actual-width il:of super il:with new-width) (propagate-width-change context super super-width)) ((eq super-width (il:iplus old-width (il:idifference (il:fetch start-x il:of node) (il:fetch start-x il:of super)))) (recompute-width super) (propagate-width-change context super super-width)))) (t (il:replace actual-width il:of super il:with width) (il:replace il:width il:of (il:windowprop (il:fetch display-window il:of context) (quote il:extent)) il:with width)))))
)

(recompute-width

(il:lambda (node) (il:* il:\; "Edited 17-Nov-87 11:19 by DCB") (il:* il:|;;;| "determine the width of this node.  we keep it fast by being tricky and skipping over subnodes which span several lines (we assume their widths are correct) so it isn't pretty") (prog ((line (il:fetch first-line il:of node)) (last-line (il:fetch last-line il:of node)) (startx (il:fetch start-x il:of node)) width) (when (eq line last-line) (il:shouldnt "trying to recompute width of an inline node")) (il:setq width (il:iplus startx (il:fetch actual-llength il:of node))) next-line (il:setq width (il:imax width (il:fetch line-length il:of line))) (when (eq (il:setq line (car (il:fetch next-line il:of line))) last-line) (go done)) (when (eq (il:fetch node il:of line) node) (go next-line)) (il:setq line (il:fetch node il:of line)) (il:setq width (il:imax width (il:iplus (il:fetch start-x il:of line) (il:fetch actual-width il:of line)))) (when (il:neq (il:setq line (il:fetch last-line il:of line)) last-line) (go next-line)) done (il:replace actual-width il:of node il:with (il:idifference width startx))))
)

(relinearize-where-necessary

(il:lambda (context) (il:* il:\; "Edited  6-Jul-87 20:50 by DCB") (il:* il:|;;;| "we've made some changes to the structure;  now it's time to fix up the linear forms and the window.  first we recompute the format types top down for all appropriate nodes.  then we recompute the width estimates for all appropriate nodes bottom up.  given this, we find a minimal set of nodes to relinearize (such that each changed node is a subnode of one of these nodes, and the structure and format type and width estimates for these nodes have not changed)") (il:* il:|;;;| "mdd 4/24/87:  as an experiment, i modified this function to always simply relinearize from the top of the tree (by imbedding (format.values.changed ...) in (OR (format.values.changed ...) T)).  this has the potential for considerably simplifying some of the linearizer.  unfortunately, it caused very noticeable performance degradation while editing large structures.  oh well.") (let ((changed-nodes (cdr (il:fetch changed-nodes il:of context))) nodes-to-relinearize) (cond ((null changed-nodes) nil) ((and (eq (il:fetch depth il:of (car changed-nodes)) 1) (null (cdr changed-nodes))) (il:* il:|;;| "special case for editing a tree of just one node") (relinearize (car changed-nodes) context) (il:replace changed? il:of (car changed-nodes) il:with nil)) (t (il:* il:|;;| "collect nodes whose structure has changed or whose format type has changed") (il:for node il:in (il:reverse changed-nodes) il:bind super-node il:when (not (dead-node? node)) il:do (il:* il:|;;| "call format method on node and its super (super first).  mark the super as changed so that it will be relinearized.") (il:setq super-node (il:fetch super-node il:of node)) (when (and super-node (not (dead-node? super-node)) (not (il:fetch changed? il:of super-node)) (il:fetch super-node il:of super-node)) (funcall (il:fetch assign-format il:of (il:fetch node-type il:of super-node)) super-node context (il:fetch format il:of super-node)) (note-change-format super-node context)) (funcall (il:fetch assign-format il:of (il:fetch node-type il:of node)) node context (il:fetch format il:of node))) (il:* il:|;;| "collect nodes whose structure has changed or whose format type has changed or whose width formats have changed: in short, all the nodes which might need relinearizing.") (il:setq changed-nodes (cdr (il:fetch changed-nodes il:of context))) (il:while changed-nodes il:bind node super-node il:do (il:setq node (car changed-nodes)) (when (not (dead-node? node)) (cond ((and (il:setq super-node (il:fetch super-node il:of node)) (format-values-changed node context) (il:fetch super-node il:of super-node)) (il:* il:|;;| "climb up the super node links until the width estimates stop changing") (when (not (il:fetch changed? il:of super-node)) (il:replace changed? il:of super-node il:with t) (insert-changed super-node changed-nodes))) (t (il:push nodes-to-relinearize node)))) (il:setq changed-nodes (cdr changed-nodes))) (il:for node il:in il:old (il:setq nodes-to-relinearize (il:dreverse nodes-to-relinearize)) il:do (if (and (cdr nodes-to-relinearize) (il:for (super-node il:_ node) il:while (il:setq super-node (il:fetch super-node il:of super-node)) il:thereis (il:fetch changed? il:of super-node))) (il:for (super-node il:_ node) il:until (il:fetch changed? il:of (il:setq super-node (il:fetch super-node il:of super-node))) il:do (il:replace changed? il:of super-node il:with t)) (relinearize node context))))) (rplacd (il:fetch changed-nodes il:of context) nil)))
)

(replace-node

(il:lambda (context node new-node) (il:* il:\; "Edited  6-Jul-87 20:50 by DCB") (il:* il:|;;;| "replace node with new.node, without changing current selection or point") (let* ((point (il:fetch caret-point il:of context)) (selection (il:fetch selection il:of context)) (select-node (il:fetch select-node il:of selection))) (smash-using edit-point temp-point point) (smash-using edit-selection temp-selection selection) (set-selection-me selection context node) (pending-delete point selection) (insert point context new-node) (smash-using edit-point point temp-point) (cond ((and select-node (dead-node? select-node)) (il:replace select-node il:of selection il:with new-node) (il:replace select-start il:of selection il:with nil) (il:replace select-end il:of selection il:with nil) (il:replace select-type il:of selection il:with (quote structure)) (il:replace pending-delete? il:of selection il:with nil)) (t (smash-using edit-selection selection temp-selection)))))
)

(replace-root

(il:lambda (root context where subnodes point) (il:* il:\; "Edited 11-Apr-88 17:02 by woz") (il:* il:|;;;| "Insert method for the root.  If we're passed a single node to insert, replace the root with it.  If we're passed several nodes, then replace the root with an empty list, set the point in that list, and return the subnodes in toto so that insert will then insert them into the new (empty) root list.") (when (and (null point) (rest subnodes)) (il:shouldnt "Replacing root with list but no point specified!")) (undo-by undo-replace-root root (subnode 1 root)) (let ((top-node (if (rest subnodes) (create-null-list context) (car subnodes)))) (kill-node (subnode 1 root)) (rplaca (cdr (il:|fetch| sub-nodes il:|of| root)) top-node) (rplaca (cdr (il:|fetch| linear-form il:|of| root)) (create-weak-link top-node)) (when (il:|fetch| inline? il:|of| top-node) (il:* il:|;;| "used to be (IL:REPLACE LAST-LINE-LINEAR IL:OF SUBNODE IL:WITH (IL:FETCH LINEAR-FORM IL:OF NODE))") (il:|replace| last-line il:|of| top-node il:|with| (car (il:|fetch| linear-form il:|of| root)))) (il:|replace| first-line il:|of| top-node il:|with| (car (il:|fetch| linear-form il:|of| root))) (il:|replace| linear-thread il:|of| top-node il:|with| (cdr (il:|fetch| linear-form il:|of| root))) (il:|replace| super-node il:|of| top-node il:|with| root) (il:|replace| sub-node-index il:|of| top-node il:|with| 1) (set-depth top-node (il:add1 (il:|fetch| depth il:|of| root))) (note-change root context) (subnode-changed-root root top-node context) (cond ((rest subnodes) (il:* il:|;;| "set the point ourself since set-point-list will blow out assuming that the list already has a linear form.") (il:|replace| point-node il:|of| point il:|with| top-node) (il:|replace| point-index il:|of| point il:|with| 0) (il:|replace| point-type il:|of| point il:|with| (quote structure)) subnodes) (point (set-point-nowhere point) nil))))
)

(revive-node

(il:lambda (node depth) (il:* il:\; "Edited  6-Jul-87 20:50 by DCB") (il:replace depth il:of node il:with (il:setq depth (il:iplus 1 depth))) (il:for subnode il:in (cdr (il:fetch sub-nodes il:of node)) il:do (revive-node subnode depth)))
)

(SEDIT1

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


(IL:* IL:|;;;| "this is the function that runs in the sedit process.  first finish the initialization that wasn't done in the calling process, then start the main loop.  The read-print profile is rebound specially here, so global changes won't affect existing SEdits.  ")


    (WHEN (IL:NEQ (IL:|fetch|
 CONTEXT-LOCK IL:|of|
 CONTEXT)
                 'DEAD)

        (IL:* IL:|;;| "this SEdit is okay, or new")


        (WITH-PROFILE
         (IL:|fetch|
 PROFILE IL:|of|
 CONTEXT)
         (SETUP-CONTEXT
 CONTEXT)
         (SETUP-WINDOW-AND-PROCESS
 CONTEXT)

         (IL:* IL:|;;| 

       "SEDIT (in start-process) is waiting for the initialization to complete before returning")


         (IL:NOTIFY.EVENT (IL:|fetch|
 COMPLETION-EVENT IL:|of|
 CONTEXT))
         (LET*
          ((LOCK (IL:|fetch|
 CONTEXT-LOCK IL:|of|
 CONTEXT))
           (DEFAULT-CHAR-HANDLER (IL:|fetch|
 DEFAULT-CHAR-HANDLER IL:|of|
 (IL:|fetch|

                                                                                   ENVIRONMENT
                                                                                     IL:|of|

                                                                                     CONTEXT)))
           (COMMAND-TABLE (IL:|fetch|
 COMMAND-TABLE IL:|of|
 (IL:|fetch|
 ENVIRONMENT
                                                                       IL:|of|
 CONTEXT)))
           (WINDOW (IL:|fetch|
 DISPLAY-WINDOW IL:|of|
 CONTEXT))
           (PROMPTWINDOW (IL:GETPROMPTWINDOW WINDOW))
           CHARCODE COMMAND THIS-CHAR-ESCAPED)
          (DECLARE
 (IL:SPECVARS THIS-CHAR-ESCAPED))
          (LOOP                                              (IL:* IL:\; 

                                    "run the command loop forever.  COMPLETE will kill the process")

                (WHEN (NULL (IL:ERSETQ                       (IL:* IL:\; 

                                                           "catch errors at top of loop")

                                   (IL:SETQ CHARCODE (GETKEY CONTEXT))

                                   (IL:* IL:|;;| 

     "AWAKE-COMMAND-PROCESS will cause getkey to return a command (a list), rather than a charcode")


                                   (IL:WITH.MONITOR LOCK
                                       (WHEN CHARCODE
                                           (IL:\\CARET.DOWN WINDOW)
                                           (SELECTION-DOWN CONTEXT)

                                 (IL:* IL:|;;| "this COND handles the different command generation cases.  A \"command\" is a list of the form (<fn-name> <normalize?> <extra-args>*), where <fn-name> is the function to apply, <normalize?> is T if SEdit should auto-scroll after this command, and <extra-args>* are zero or more extra args to the command function beyond the normal args of CONTEXT and CHARCODE.")


                                           (COND
                                              ((IL:LISTP CHARCODE)

                                               (IL:* IL:|;;| 

    "a command generated externally.  the variable command gets used later, so it must be set here")


                                               (IL:SETQ COMMAND CHARCODE)
                                               (IL:SETQ THIS-CHAR-ESCAPED NIL)
                                               (FORMAT PROMPTWINDOW "~%")
                                               (IL:APPLY (CAR COMMAND)
                                                      (LIST* CONTEXT NIL (CDDR COMMAND))))
                                              (THIS-CHAR-ESCAPED 
                                                             (IL:* IL:\; "an escaped char")

                                                     (FUNCALL DEFAULT-CHAR-HANDLER CONTEXT CHARCODE)
                                                     (IL:SETQ THIS-CHAR-ESCAPED NIL))
                                              ((AND (OR (IL:SETQ COMMAND (LOOKUP-COMMAND CHARCODE 
                                                                                COMMAND-TABLE))
                                                        (IL:SETQ COMMAND (LOOKUP-COMMAND (
                                                                                         IL:GETSYNTAX
                                                                                          CHARCODE)
                                                                                COMMAND-TABLE)))
                                                    (IL:APPLY (CAR COMMAND)
                                                           (LIST* CONTEXT CHARCODE (CDDR COMMAND))))

                                               (IL:* IL:|;;| 

                          "this is a valid command or syntax char, and it has already been handled")


                                               )
                                              (T 
                                                 (IL:* IL:|;;| 

                "none of the above, or else the command didn't want to run.  treat as normal input")


                                                 (FUNCALL DEFAULT-CHAR-HANDLER CONTEXT CHARCODE)))
                                           (WHEN (OR (NOT COMMAND)
                                                     (NOT (IL:FMEMB (CAR COMMAND)
                                                                 '(UNDO REDO))))
                                                 (IL:|replace|
 UNDO-UNDO-LIST IL:|of|
 CONTEXT
                                                    IL:|with|
 NIL)))

                                       (IL:* IL:|;;| 

                                 "unless the user is typing too fast to keep up, fix up the window")


                                       (UNLESS (IL:\\SYSBUFP)
                                           (UPDATE
 CONTEXT NIL (SECOND COMMAND))

                                 (IL:* IL:|;;| "once the update has triggerred on this command, set it to nil so other updates without a new command (shift selection...) won't update with an old command.")


                                           (SETQ COMMAND NIL)))))

                    (IL:* IL:|;;| "on catching of errors, re-update to capture what was undone to run the command, like the current selection")


                    (UPDATE
 CONTEXT T))))))))

(select-next-gap

(il:lambda (context node index) (il:* il:\; "Edited 23-Nov-87 18:23 by DCB") (il:setq node (next-node node index)) (il:while node il:do (when (eq (il:fetch node-type il:of node) type-gap) (select-segment (il:fetch selection il:of context) context (il:fetch super-node il:of node) node node) (pending-delete (il:fetch caret-point il:of context) (il:fetch selection il:of context)) (return t)) (il:setq node (next-node node)) il:finally (set-selection-nowhere (il:fetch selection il:of context))))
)

(set-depth

(il:lambda (node depth) (il:* il:\; "Edited 17-Nov-87 11:19 by DCB") (il:* il:|;;;| "set the depth of this subtree") (il:replace depth il:of node il:with depth) (il:for x il:in (cdr (il:fetch sub-nodes il:of node)) il:do (set-depth x (il:add1 depth))))
)

(set-format

(il:lambda (node context format) (il:* il:\; "Edited  6-Jul-87 20:51 by DCB") (il:* il:|;;;| "a node's AssignFormat method may assign a format type (such as KeyWord or BindingList) to its immediate subnodes.  to do so, it should call set.format rather than setting the Format field directly.  if the format type assigned is different from the old one, this function will note the node as changed and run the AssignFormatTypes method for node to give it a chance to assign new format types to its children based upon its own changed format type.  For example, if a node's parent changed its format type from NIL to BindingList, the node will have to get a chance to change each of its children from NIL to Binding; and these will have to get a chance to reset themselves.") (il:* il:|;;;| "") (il:* il:|;;;| "if we are visiting every node anyway (for example, just after building the tree), we don't want to collect changed nodes and automatically propagate changed formats.") (il:* il:|;;;| "") (il:* il:|;;;| "the rough equivalent of the format type used to be determined in the parse phase and was known as the ParseMode.  back then there was reparsing (which happened every time a node changed), and the reparser could reset the ParseMode.  reparsing was determined to be at best unnecessary and at worst an evil, since reparsing during copy-selection can be disastrous.  (think of copy-selecting (QUOTE A) from a TEdit window: you reparse from list to quote, get 'A, and do the wrong thing with the closing parenthesis.)") (il:* il:|;;;| "") (when (not (il:equal (il:fetch format il:of node) format)) (il:replace format il:of node il:with format) (note-change-format node context) (when (not (il:fetch dont-collect-changes? il:of context)) (funcall (il:fetch assign-format il:of (il:fetch node-type il:of node)) node context format))))
)

(SETUP-CONTEXT

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


(IL:* IL:|;;;| "confirm that this context is setup.  that means either setting up a new context or verifying the structure in an old one, and setting the initial selection")


    (COND
       ((NULL (IL:|fetch|
 CONTEXT-LOCK IL:|of|
 CONTEXT))

        (IL:* IL:|;;| "this is a new sedit.  setup its profile, and then the context itself")


        (SETUP-PROFILE
 (IL:|fetch|
 PROFILE IL:|of|
 CONTEXT)
               CONTEXT)
        (SETUP-NEW-CONTEXT
 CONTEXT))
       ((AND (IL:|fetch|
 CHANGED-STRUCTURE? IL:|of|
 CONTEXT)
             (NOT (EQ (IL:|fetch|
 CHANGED-STRUCTURE? IL:|of|
 CONTEXT)
                      T)))

        (IL:* IL:|;;| "this is an old context getting restarted with a new structure stashed in the context by SEDIT.  this means the new structure is not EQ with our structure.  verify what we've got againt this new structure, and since it might be different, we have to throw away our edit history.")


        (VERIFY-STRUCTURE
 CONTEXT NIL (IL:|fetch|
 CHANGED-STRUCTURE? IL:|of|
 CONTEXT))
        (THROW-AWAY-CHANGES CONTEXT))
       (T 
          (IL:* IL:|;;| "just verify what we've already got.")


          (VERIFY-STRUCTURE
 CONTEXT)))
    (SET-INITIAL-SELECTION
 CONTEXT)))

(setup-context-window-dependencies

(il:lambda (context) (il:* il:\; "Edited  6-Jul-87 20:51 by DCB") (il:* il:|;;;| "setup the fields in the context that depend on the window being built") (let ((window (il:fetch display-window il:of context))) (il:* il:|;;| "set the context's comment column info based on the window.") (compute-comment-column context window)))
)

(SETUP-NEW-CONTEXT

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


(IL:* IL:|;;;| "this is a new context: build all the necessary data structures.")


    (LET ((LOCK (IL:CREATE.MONITORLOCK (IL:CONCAT EDITOR-NAME (IL:|fetch|
 ICON-TITLE IL:|of|

                                                                                         CONTEXT)))))
         (IL:|replace|
 CONTEXT-LOCK IL:|of|
 CONTEXT IL:|with|
 LOCK)
         (IL:WITH.MONITOR LOCK
             (BUILD-WINDOW CONTEXT)
             (SETUP-CONTEXT-WINDOW-DEPENDENCIES
 CONTEXT)
             (BUILD-INTERNAL-STRUCTURE
 CONTEXT)
             (SETUP-WINDOW-CONTEXT-DEPENDENCIES
 CONTEXT)))))

(setup-profile

(il:lambda (profile context) (il:* il:\; "Edited 16-Feb-88 11:14 by raf") (il:* il:|;;;| "here we set up the specifics about the profile of the world we're editing in, based on what we're editing.  this function must be called under WITH-PROFILE, so that the current bindings reflect the profile, because we update the profile by changing the binding as necessary and then re-saving the profile.") (il:* il:|;;;| "Use current readtable, print-base, print-case, print-level, print-length.") (il:* il:|;;;| "Set package based on name of structure editing.  Maybe should be changed to reflect package of profile of file function lives in.") (il:* il:|;;;| "The rest get forced to appropriate values for editing.") (il:setq *read-base* 10) (il:setq *read-suppress* nil) (il:setq *package* (default-package (il:fetch icon-title il:of context) (il:fetch edit-type il:of context) (il:fetch root il:of context))) (il:setq *print-escape* t) (il:* il:\; "shouldn't matter") (il:setq *print-pretty* nil) (il:setq *print-circle* nil) (il:setq *print-radix* (il:neq *print-base* 10)) (il:* il:\; "interlisp semantics ") (il:setq *print-gensym* t) (il:setq *print-array* nil) (il:* il:\; "until we can edit ") (il:setq *print-structure* nil) (il:* il:\; "the structures.") (save-profile profile))
)

(SETUP-WINDOW-AND-PROCESS

  (IL:LAMBDA (CONTEXT)
                              (IL:* IL:\; "Edited  2-Dec-92 17:27 by jds")

    (LET ((PROCESS (IL:THIS.PROCESS))
          (WINDOW (IL:FETCH
 DISPLAY-WINDOW IL:OF
 CONTEXT)))
         (WHEN (AND (IL:WINDOWPROP WINDOW 'IL:PROCESS)
                    (IL:NEQ PROCESS (IL:WINDOWPROP WINDOW 'IL:PROCESS)))

             (IL:* IL:|;;| 

   "it's okay if the same process is there already. this the case of RESET restarting the process.")


             (IL:SHOULDNT "There's already a command process for this SEdit!"))
         (IL:WINDOWPROP WINDOW 'IL:PROCESS PROCESS)
         (UPDATE-TITLE CONTEXT WINDOW T)
         (IL:SETTERMTABLE TERMINAL-TABLE)
         (IL:PROCESSPROP PROCESS 'IL:WINDOW WINDOW)
         (IL:PROCESSPROP PROCESS 'IL:TTYEXITFN (IL:FUNCTION TTYEXITFN))
         (IL:PROCESSPROP PROCESS 'IL:KEYACTION (LET ((IL:TABLE (IL:KEYACTIONTABLE 
                                                                      IL:\\CURRENTKEYACTION)))
                                                    (IL:SETINTERRUPT (IL:CHARCODE IL:DEL)
                                                           NIL IL:TABLE)
                                                    IL:TABLE))
         (IL:PROCESSPROP PROCESS 'IL:RESTARTABLE T)
         (IL:TTY.PROCESS PROCESS)
         (IL:CLEARW (IL:GETPROMPTWINDOW WINDOW))
         (IL:TTYDISPLAYSTREAM IL:PROMPTWINDOW))))

(setup-window-context-dependencies

(il:lambda (context) (il:* il:\; "Edited  6-Jul-87 20:51 by DCB") (il:* il:|;;;| "setup the window properties that depend on the context being build and sedit structure computed") (let* ((window (il:fetch display-window il:of context)) (root (il:fetch root il:of context)) (height (il:idifference (il:fetch line-height il:of (il:fetch last-line il:of root)) (il:fetch ycoord il:of (il:fetch last-line il:of root))))) (il:* il:|;;| "now that we know about the structures, we can set the window's extent") (il:windowprop window (quote il:extent) (il:create il:region il:left il:_ 0 il:bottom il:_ (il:idifference 1 height) il:width il:_ (il:fetch actual-width il:of root) il:height il:_ height)) (il:* il:|;;| "and cache the title info for update.title") (il:windowprop window (quote title-info) (list :|ChangedStructure?| nil :|package| *package* :|name| (il:fetch icon-title il:of context)))))
)

(shift-linear-form

(il:lambda (node right-shift) (il:* il:\; "Edited 11-Apr-88 17:04 by woz") (il:* il:|;;;| "this node's linear form has just been shifted left or right.  adjust its StartX value and that of any of its subnodes which are being displayed") (il:|replace| start-x il:|of| node il:|with| (il:iplus (il:|fetch| start-x il:|of| node) right-shift)) (il:|for| x il:|in| (il:|fetch| linear-form il:|of| node) il:|when| (il:|type?| weak-link x) il:|do| (shift-linear-form (il:|fetch| destination il:|of| x) right-shift)))
)

(stringify

(il:lambda (node environment) (il:* il:\; "Edited  6-Jul-87 20:51 by DCB") (funcall (il:fetch stringify il:of (il:fetch node-type il:of node)) node environment))
)

(stringify-gap

(il:lambda (node environment) (il:* il:\; "Edited  6-Jul-87 20:51 by DCB") "-?-"))

(subnode-changed

(il:lambda (node context) (il:* il:\; "Edited 17-Nov-87 11:20 by DCB") (il:* il:|;;;| "inform a node that one of its subnodes has been replaced") (funcall (il:fetch sub-node-changed il:of (il:fetch node-type il:of (il:fetch super-node il:of node))) (il:fetch super-node il:of node) node context))
)

(subnode-changed-root

(il:lambda (node subnode context) (il:* il:\; "Edited 19-Jan-88 14:25 by woz") (let ((fn (il:fetch root-changed-fn il:of context)) extra-args) (when fn (when (and (listp fn) (not (member (first fn) (quote (lambda il:lambda))))) (il:* il:|;;| "check for the #' case (car fn) = lambda.  should be able to use functionp, but it returns t for an arbitrary list, which is a bug.") (setq extra-args (rest fn)) (setq fn (first fn))) (apply fn (cons (il:fetch structure il:of subnode) extra-args)))))
)

(type-of-input

(il:lambda (context) (il:* il:\; "Edited  6-Jul-87 20:51 by DCB") (il:* il:\; "access fn for the type of input expected") (and (il:fetch point-node il:of (il:fetch caret-point il:of context)) (il:fetch point-type il:of (il:fetch caret-point il:of context))))
)

(undo-event

(il:lambda (event context) (il:* il:\; "Edited 17-Nov-87 11:20 by DCB") (cond ((null event) (il:* il:|;;| "someone got confused and left an unmatched blip on the undo list -- do nothing") nil) ((il:listp (car event)) (start-undo-block) (il:for subevent il:in event il:do (undo-event subevent context)) (end-undo-block)) (t (il:apply (car event) (cons context (cdr event))))))
)

(undo-replace-root

(il:lambda (context node old-value) (il:* il:\; "Edited  6-Jul-87 20:51 by DCB") (when (not (dead-node? old-value)) (il:shouldnt "undo is confused!")) (replace-root node context (subnode 1 node) (list old-value) nil))
)

(UPDATE

  (IL:LAMBDA (CONTEXT RELINEARIZE SCROLL?)
         (IL:* IL:\; "Edited 13-Jun-88 18:57 by Snow")


    (IL:* IL:|;;| "fix up the window after changes to the structure.  relinearize.where.necessary will fix up the formatting, and we also have to figure out where the point and selection should be displayed")


    (LET ((WINDOW (IL:|fetch|
 DISPLAY-WINDOW IL:|of|
 CONTEXT))
          (SELECTION (IL:|fetch|
 SELECTION IL:|of|
 CONTEXT)))
         (IF RELINEARIZE
             (PROGN (RELINEARIZE (IL:|fetch|
 ROOT IL:|of|
 CONTEXT)
                           CONTEXT)
                    (FORMAT (GET-PROMPT-WINDOW CONTEXT)
                           "~%~%"))
             (RELINEARIZE-WHERE-NECESSARY
 CONTEXT))
         (CHECK-SELECTION SELECTION (IL:|fetch|
 CARET-POINT IL:|of|
 CONTEXT))
         (COMPUTE-SELECTION-POSITION
 SELECTION CONTEXT)
         (SELECTION-UP CONTEXT)
         (UPDATE-TITLE CONTEXT WINDOW)
         (SHOW-CARET CONTEXT T SCROLL?))))

(VERIFY-STRUCTURE

  (IL:LAMBDA (CONTEXT CHARCODE STRUCTURE REDISPLAY-ALWAYS? CLEAR-LINEAR-FORMS?)

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


(IL:* IL:|;;;| "reparse and relinearize as necessary to make sure the sedit is current.  can be called as a command, so must have context and charcode args.  the STRUCTURE are can be a new structure to verify against.  this happens when someone changed the structure under an existing edit and we found out about it.  otherwise we just check what we've already got.")


    (LET* ((ROOT (IL:|fetch|
 ROOT IL:|of|
 CONTEXT))
           (CHECK-STRUCTURE (OR STRUCTURE (IL:|fetch|
 STRUCTURE
                                             IL:|of|
 (CADR (IL:|fetch|
 SUB-NODES IL:|of|

                                                                                         ROOT))))))
          (IL:WITH.MONITOR (IL:|fetch|
 CONTEXT-LOCK IL:|of|
 CONTEXT)
              (CLOSE-OPEN-NODE CONTEXT)
              (IL:|replace|
 CURRENT-NODE IL:|of|
 CONTEXT IL:|with|
 ROOT)
              (IL:|replace|
 \\X IL:|of|
 CONTEXT IL:|with|
 (IL:|fetch|
 SUB-NODES
                                                                         IL:|of|
 ROOT))
              (IL:|replace|
 SUB-NODES IL:|of|
 ROOT IL:|with|
 (LIST 0))
              (PARSE
 CHECK-STRUCTURE CONTEXT)
              (COMPUTE-ALL-FORMATS
 CONTEXT)
              (WHEN CLEAR-LINEAR-FORMS? (CLEAR-ALL-LINEAR-FORMS CONTEXT))
              (COND
                 ((OR CLEAR-LINEAR-FORMS? (IL:|fetch|
 CHANGED? IL:|of|
 ROOT))
                  (SELECTION-DOWN CONTEXT)
                  (RELINEARIZE ROOT CONTEXT)
                  (SET-SELECTION-NOWHERE (IL:|fetch|
 SELECTION IL:|of|
 CONTEXT))
                  (SET-POINT-NOWHERE (IL:|fetch|
 CARET-POINT IL:|of|
 CONTEXT))
                  (UPDATE
 CONTEXT))
                 (REDISPLAY-ALWAYS? 

                        (IL:* IL:|;;| "this used to be here as a way to see the edit-date change.  now nobody calls us with this flag set, so it could be removed.  wasn't cause of change control.")


                        (IL:REDISPLAYW (IL:|fetch|
 DISPLAY-WINDOW IL:|of|
 CONTEXT))))
              (RPLACD (IL:|fetch|
 CHANGED-NODES IL:|of|
 CONTEXT)
                     NIL)))))

(walk-up-tree

(il:lambda (node context fn) (il:* il:\; "Edited 25-Aug-87 09:50 by drc:") (dolist (subnode (cdr (il:fetch sub-nodes il:of node))) (walk-up-tree subnode context fn)) (funcall fn node context))
)
)
(IL:PUTPROPS IL:SEDIT-BASE IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 1991 1992))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (9218 104008 (ADJUST-WIDTH 9231 . 9977) (ASSIGN-FORMAT-NIL 9979 . 10687) (
ATOM-CHANGE-RELINEARIZE 10689 . 12356) (BUILD-INTERNAL-STRUCTURE 12358 . 14276) (BUILD-LINEAR-FORM 
14278 . 20897) (BUILD-NODE 20899 . 22365) (BUILD-PRELINEARIZED-NODE 22367 . 23781) (CLOSE-NODE 23783
 . 24212) (COLLECT-UNDO-BLOCK 24214 . 25044) (COMPILE-STRUCTURE 25046 . 26125) (COMPUTE-ALL-FORMATS 
26127 . 26601) (COMPUTE-FORMATS-AND-FORMAT-VALUES 26603 . 27682) (COMPUTE-POINT-POSITION 27684 . 28290
) (COMPUTE-SELECTION-POSITION 28292 . 29413) (COMPUTE-SELECTION-POSITION-DEFAULT 29415 . 30414) (
CONTAINS? 30416 . 32597) (COPY-NODE 32599 . 36236) (COPY-SELECTION 36238 . 37824) (
COPY-SELECTION-DEFAULT 37826 . 39461) (CREATE-CONSTANT-STRINGS 39463 . 40320) (CREATE-ENVIRONMENTS 
40322 . 45288) (CREATE-GAP-NODE 45290 . 46506) (CREATE-NODE 46508 . 47836) (CREATE-PRELINEARIZED-NODE 
47838 . 48722) (CREATE-PRETTY-PRINT-ENV 48724 . 49898) (CREATE-SIMPLE-NODE 49900 . 51171) (
CREATE-STRING-ITEM 51173 . 51381) (DEFAULT-COMPILE-FN 51383 . 51550) (DEFAULT-GETDEF-FN 51552 . 51838)
 (DEFAULT-PACKAGE 51840 . 52163) (DELETE-NODES 52165 . 52733) (DETACH-NODE 52735 . 52978) (
FORMAT-VALUES-CHANGED 52980 . 54116) (GET-SELECTED-STRUCTURE 54118 . 54682) (HANDLE-COMPLETION 54684
 . 56844) (INITIALIZE 56846 . 60029) (INSERT 60031 . 64011) (INSERT-CHANGED 64013 . 64451) (KILL-NODE 
64453 . 65057) (LINEARIZE-ROOT 65059 . 65252) (NEXT-NODE 65254 . 65988) (NOTE-CHANGE 65990 . 66889) (
NOTE-CHANGE-FORMAT 66891 . 67788) (NOTE-CHANGE-IN-SIMPLE 67790 . 68695) (PARSE 68697 . 71229) (
PARSE--GAP 71231 . 72572) (PARSE--UNKNOWN 72574 . 73027) (PARSE-NEW 73029 . 73245) (
PROPAGATE-WIDTH-CHANGE 73247 . 74525) (RECOMPUTE-WIDTH 74527 . 75640) (RELINEARIZE-WHERE-NECESSARY 
75642 . 79185) (REPLACE-NODE 79187 . 80174) (REPLACE-ROOT 80176 . 82094) (REVIVE-NODE 82096 . 82352) (
SEDIT1 82354 . 88940) (SELECT-NEXT-GAP 88942 . 89460) (SET-DEPTH 89462 . 89731) (SET-FORMAT 89733 . 
91590) (SETUP-CONTEXT 91592 . 92991) (SETUP-CONTEXT-WINDOW-DEPENDENCIES 92993 . 93361) (
SETUP-NEW-CONTEXT 93363 . 94106) (SETUP-PROFILE 94108 . 95411) (SETUP-WINDOW-AND-PROCESS 95413 . 96848
) (SETUP-WINDOW-CONTEXT-DEPENDENCIES 96850 . 97784) (SHIFT-LINEAR-FORM 97786 . 98320) (STRINGIFY 98322
 . 98500) (STRINGIFY-GAP 98502 . 98603) (SUBNODE-CHANGED 98605 . 98924) (SUBNODE-CHANGED-ROOT 98926 . 
99446) (TYPE-OF-INPUT 99448 . 99727) (UNDO-EVENT 99729 . 100122) (UNDO-REPLACE-ROOT 100124 . 100366) (
UPDATE 100368 . 101384) (VERIFY-STRUCTURE 101386 . 103792) (WALK-UP-TREE 103794 . 104006)))))
IL:STOP