(setq rcs-cmuedit-
   "$Header: cmuedit.l 1.1 86/05/20 $")

(eval-when (compile load eval) (load 'cmumacs) (load 'cmufncs))

(declare (special c2 c3 tem nopr %changes))

(dv editsfns
    ((declare
      (special |#1|
               |#2|
               |#3|
               $%dotflg
               %lookdpth
               %prevfn%
               atm
               autop
               com
               com0
               coms
               copyflg
               editcomsl
               editracefn
               %%w
               findflag
               l
               l0
               lastail
               lastp1
               lastp2
               lastword
               lcflg
               marklst
               maxlevel
               maxloop
               mess
               noprint
               oldprompt
               readbuf
               %%x
               toflg
               topflg
               undolst
               undolst1
               unfind
               upfindflg
               usermacros
               findarg
               commentflg
               changed))
     |##|
     editfns
     editf
     editv
     editp
     edite
     editl
     editl0
     edval
     editread
     (declare (*expr editracefn))
     editcom
     editcoma
     editcoml
     editmac
     editcoms
     edith
     edit!undo
     undoeditcom
     editsmash
     editnconc
     editdsubst
     edit1f
     edit2f
     edit4e
     editqf
     edit4f
     editfpat
     edit4f1
     editfindp
     editbf
     editbf1
     editnth
     bpnt0
     bpnt
     editri
     editro
     editli
     editlo
     editbi
     editbo
     editdefault
     edup
     edit*l
     edit*
     edor
     errcom
     edrpt
     edloc
     edlocl
     edit:
     editmbd
     editxtr
     editelt
     editcont
     editsw
     editmv
     editto
     editbelow
     editran
     edit!0
     editrepack
     editmakefn
     usermacros
     editracefn
     lastword
     maxlevel
     maxloop
     editcomsl
     autop
     upfindflg))

(declare
 (special |#1|
          |#2|
          |#3|
          $%dotflg
          %lookdpth
          %prevfn%
          atm
          autop
          com
          com0
          coms
          copyflg
          editcomsl
          editracefn
          %%w
          findflag
          l
          l0
          lastail
          lastp1
          lastp2
          lastword
          lcflg
          marklst
          maxlevel
          maxloop
          mess
          noprint
          oldprompt
          readbuf
          %%x
          toflg
          topflg
          undolst
          undolst1
          unfind
          upfindflg
          usermacros
          findarg
          commentflg
          changed))
(declare (special c nopr))	; LWE 1/11/80 Hacks for new compiler.
(def |##|
  (nlambda (coms)
    ((lambda (l undolst1) (editcoms coms)) l nil)))

(def editfns
  (nlambda (x)
    (prog (y)
          (setq y (eval (car x)))
     l1   (cond
           (y (print (car y))
              (eval
               (list 'errset
                     (cons 'editf (cons (car y) (cdr x)))))
              (setq y (cdr y))
              (go l1))))))

(def editf
  (nlambda (x)
    (prog (y fn changed)
          (cond
           ((null x)
            (print '=)
            (prin1 lastword)
            (setq x (ncons lastword))))
          (cond ((symbolp (car x))
                 (setq fn (car x))
                 (cond ((*** setq y (get fn 'trace)) (setq fn (cdr y))))
                 (cond ((setq y (getd fn))
                        (edite y (cdr x) (car x))
                        (cond
                         (changed
                          (*** cond
                               ((eq (car x) fn)
                                (*** move property to front)
                                (remprop (car x) (car y))
                                (putprop (car x) (cadr y) (car y)))
                               ((setq y (cdr (get fn 'funtype)))
                                (*** move the *right* property of the
                                 original word to the front)
                                (setq fn (get (car x) y))
                                (remprop (car x) y)
                                (putprop (car x) fn y)))))
                        (return (setq lastword (car x))))
                       ((and (boundp fn) (dtpr (cdr y))) (go l1))))
                ((dtpr (car x)) (go l1)))
          (print (car x))
          (princ '" not editable")
          (err nil)
     l1   (print '=editv)
          (return (eval (cons 'editv x))))))

(def editv
  (nlambda (x)
    (prog (y)
          (cond
           ((null x)
            (print '=)
            (prin1 lastword)
            (setq x (ncons lastword))))
          (cond ((dtpr (car x)) (edite (eval (car x)) (cdr x) nil) (return t))
                ((and (symbolp (car x))
                      (boundp (car x))
                      (setq y (eval (car x))))
                 (edite y (cdr x) (car x))
                 (return (setq lastword (car x))))
                (t (print (car x)) (princ '" not editable") (err nil))))))

(def editp
  (nlambda (x)
    (cond
     ((null x) (print '=) (prin1 lastword) (setq x (ncons lastword))))
    (cond ((dtpr (car x)) (print '=editv) (eval (cons 'editv x)))
          ((symbolp (car x))
           (edite (plist (car x)) (cdr x) (car x))
           (setq lastword (car x)))
          (t (print (car x)) (princ '" not editable") (err nil)))))

(def edite
  (lambda (expr coms atm)
    (cond ((atom expr) (print expr) (princ '" not editable") (err nil))
          (t (car (last (editl (ncons expr) coms atm nil nil)))))))

(def editl
  (lambda (l coms atm marklst mess)
    (prog (com lastail undolst undolst1 findflag lcflg unfind lastp1 lastp2 readbuf l0 com0 oldprompt upfindflg noprint findarg)
          (makunbound 'findarg)
          (setq upfindflg t)
          (cond ((dtpr (setq l (catch (eval '(editl0)) edit-abort)))
                 (return l))
                (t (err nil))))))

(def editl0
  (lambda nil
    (prog nil
          (cond
           (coms
            (cond ((eq (car coms) 'start)
                   (setq readbuf (append (cdr coms) (list nil)))
                   (setq coms nil)
                   (*** don 't quit if command fails))
                  (t (editcoms (append coms (list 'ok))) (return l)))))
          (cond
           ((or (null coms) (eq (car coms) 'start))
            (print (or mess 'edit))))
          (cond
           ((or (eq (car l)
                    (car
                     (last
                      (car
                       (cond ((setq com
                                    (get 'edit 'lastvalue)))
                             (t '((nil))))))))
                (and atm
                     (eq (car l)
                         (car
                          (last
                           (car
                            (cond ((setq com
                                         (get atm 'edit-save)))
                                  (t '((nil))))))))))
            (setq l (car com))
            (setq marklst (cadr com))
            (setq undolst (caddr com))
            (cond ((car undolst) (setq undolst (cons nil undolst))))
            (setq unfind (cdddr com))))
          (*** setq
               oldprompt
               (cons (sub1 (stkcount 'editl0 (add1 (spdlpt)) 0))
                     (prompt 35)))
     ct   (setq noprint t)
          (setq findflag nil)
     a    (setq undolst1 nil)
          (cond
           ((and autop (null readbuf) (not noprint)) (bpnt (list 0 autop))))
          (setq com (editread))
          (setq l0 l)
          (setq com0 (cond ((atom com) com) (t (car com))))
          (cond
           ((dtpr
             (prog1 (errset (editcom com t))
                    (cond
                     (undolst1 (setq undolst1
                                     (cons com0 (cons l0 undolst1)))
                               (setq undolst (cons undolst1 undolst))))))
            (go a)))
          (setq readbuf nil)
          (cond (coms (err nil)))
          (terpri)
          (cond (com (prin1 com) (princ '"  ?") (terpri)))
          (go ct))))

(def edval
  (lambda (%%x)
    (errset (eval %%x))))

(def editread
  (lambda nil
    (prog (x)
          (cond
           ((null readbuf)
            (prog nil
             l1   (terpri)
                  (princ '|#|)
                  (*** cond
                       ((neq (car oldprompt) 0) (princ (car oldprompt))))
                  (*** prompt 35)
                  (cond
                   ((atom (setq readbuf (errset (lineread))))
                    (terpri)
                    (go l1)))
                  (setq readbuf (car readbuf)))))
          (setq x (car readbuf))
          (setq readbuf (cdr readbuf))
          (return x))))

(declare (*expr editracefn))

(def editcom
  (lambda (c topflg)
    (setq com c)
    (cond (editracefn (editracefn c)))
    (cond (findflag
           (cond ((eq findflag 'bf) (setq findflag nil) (editbf c nil))
                 (t (setq findflag nil) (editqf c))))
          ((numberp c) (setq l (edit1f c l)) (setq noprint nil))
          ((atom c) (editcoma c (null topflg)))
          (t (editcoml c (null topflg))))
    (car l)))

(def editcoma
  (lambda (c copyflg)
    (prog (tem nopr)
          (selectq c
                   (help (setq nopr t)
                         (eval (cons 'help readbuf))
                         (setq readbuf nil)
                         (*** inserted dec 78 by don cohen))
                   (!0 (edit!0))
                   (!nx
                    (setq l
                          ((lambda (l)
                                   (prog (uf)
                                         (setq uf l)
                                    lp   (cond ((or (null (setq l (cdr l)))
                                                    (null (cdr l)))
                                                (err nil))
                                               ((or (null
                                                     (setq tem
                                                           (memq (car l)
                                                                 (cadr
                                                                  l))))
                                                    (null (cdr tem)))
                                                (go lp)))
                                         (edit* 1)
                                         (setq unfind uf)
                                         (return l)))
                           l)))
                   (!undo (edit!undo t t nil))
                   (? (bpnt0 (car l) 64) (setq nopr t))
                   (?? (edith undolst) (setq nopr t))
                   (bk (edit* -1))
                   (delete (setq c '(delete)) (edit: ': nil nil))
                   (mark (setq marklst (cons l marklst)) (setq nopr t))
                   (nex
                    (setq l
                          ((lambda (l) (editbelow '_ 1) (edit* 1) l)
                           l)))
                   ((f bf)
                    (cond ((null topflg) (setq findflag c))
                          (t (setq findarg
                                   (cond ((or readbuf
                                              (not
                                               (boundp 'findarg)))
                                          (editread))
                                         (t findarg)))
                             (selectq c
                                      (f (editqf findarg))
                                      (bf (editbf findarg nil))
                                      (err nil)))))
                   (nil (setq nopr t))
                   (autop nil)
                   (nx (edit* 1))
                   (ok (cond
                        (atm (cond
                              ((and (dtpr undolst) (car undolst))
                               (setq changed t)
                               (*** bound in editf)
                               (mark!changed atm)))
                             (remprop atm 'edit-save)))
                       (putprop 'edit
                                (cons (last l) (cons marklst (cons undolst l)))
                                'lastvalue)
                       (throw l edit-abort)
                       (*** prompt (cdr oldprompt))
                       (*** retfrom 'editl0 l))
                   (p (bpnt0 (car l) 2) (setq nopr t))
                   (pp (bpnt0 (car l) nil) (setq nopr t))
                   (pp* ((lambda (commentflg) (bpnt0 (car l) nil)) t)
                        (setq nopr t))
                   (repack (editrepack))
                   (save (cond
                          (atm (cond
                                ((and (dtpr undolst) (car undolst))
                                 (mark!changed atm)))
                               (putprop 'edit
                                        (putprop atm
                                                 (cons l
                                                       (cons marklst
                                                             (cons undolst
                                                                   unfind)))
                                                 'edit-save)
                                        'lastvalue)))
                         (*** prompt (cdr oldprompt))
                         (*** retfrom 'editl0 l)
                         (throw l edit-abort))
                   (stop (*** prompt (cdr oldprompt))
                         (*** spreval
                              (stksrch 'editl0 (spdlpt) nil)
                              '(err nil))
                         (throw nil edit-abort))
                   (test (setq undolst (cons nil undolst)) (setq nopr t))
                   (tty: (setq com com0)
                         (setq l (editl l nil atm nil 'tty:)))
                   (unblock (cond ((setq tem (memq nil undolst))
                                   (editsmash tem (ncons nil) (cdr tem)))
                                  (t (terpri) (princ '"not blocked")))
                            (setq nopr t))
                   (undo (edit!undo topflg nil (cond (readbuf (editread)))))
                   (up (edup))
                   (/
                    (cond (unfind (setq c l)
                                  (setq l unfind)
                                  (and (cdr c) (setq unfind c)))
                          (t (err nil))))
                   (/p
                    (cond ((and lastp1 (neq lastp1 l)) (setq l lastp1))
                          ((and lastp2 (neq lastp2 l)) (setq l lastp2))
                          (t (err nil))))
                   (^ (and (cdr l) (setq unfind l)) (setq l (last l)))
                   (_
                    (cond (marklst (and (cdr l) (setq unfind l))
                                   (setq l (car marklst)))
                          (t (err nil))))
                   (__
                    (cond (marklst
                           (and (cdr l)
                                (setq unfind l)
                                (setq l (car marklst))
                                (setq marklst (cdr marklst))))
                          (t (err nil))))
                   (tl (top-level) (setq nopr t))
                   (cond ((null (setq tem (editmac c usermacros nil)))
                          (editdefault c)
                          (setq nopr noprint))
                         (t (editcoms (copy (cdr tem))) (setq nopr noprint))))
          (setq noprint nopr))))

(def editcoml
  (lambda (c copyflg)
    (prog (c2 c3 tem nopr)
     lp   (cond ((dtpr (cdr c))
                 (setq c2 (cadr c))
                 (cond ((dtpr (cddr c)) (setq c3 (caddr c)))
                       (t (setq c3 nil))))
                (t (setq c2 (setq c3 nil))))
          (cond ((and lcflg
                      (selectq c2
                               ((to thru through)
                                (cond
                                 ((null (cddr c))
                                  (setq c3 -1)
                                  (setq c2 'thru)))
                                t)
                               nil))
                 (editto (car c) c3 c2)
                 (return nil))
                ((numberp (car c))
                 (edit2f (car c) (cdr c))
                 (setq noprint nil)
                 (return nil))
                ((eq c2 '::)
                 (editcont (car c) (cddr c))
                 (setq noprint nil)
                 (return nil)))
          (selectq (car c)
                   ((a b :) (edit: (car c) nil (cdr c)))
                   (below (editbelow c2 (cond ((cddr c) c3) (t 1))))
                   (bf (editbf c2 c3))
                   (bi
                    (editbi c2
                            (cond ((cddr c) c3) (t c2))
                            (and (cdr c) (car l))))
                   (bind (prog (|#1| |#2| |#3|)
                               (editcoms (cdr c)))
                         (setq nopr noprint))
                   (bk (edit* (minus c2)))
                   (bo (editbo c2 (and (cdr c) (car l))))
                   (change (editran c '((to) (edit: : |#1| |#3|))))
                   (coms (prog nil
                          l1   (cond
                                ((setq c (cdr c))
                                 (editcom (setq com (eval (car c))) nil)
                                 (go l1))))
                         (setq nopr noprint))
                   (comsq (editcoms (cdr c)) (setq nopr noprint))
                   (copy
                    (editran c '((to) (editmv |#1| (car |#3|) (cdr |#3|) t))))
                   (cp (editmv nil (cadr c) (cddr c) t))
                   (delete (editran c '(nil (edit: : |#1| nil))))
                   (e (setq tem (eval c2))
                      (cond ((null (cddr c)) (print tem)))
                      (setq nopr t))
                   (embed (editran c '((in with) (editmbd |#1| |#3|))))
                   (extract (editran c '((from) (editxtr |#3| |#1|))))
                   (f (edit4f c2 c3))
                   (f= (edit4f (cons '== c2) c3))
                   (fs
                    (prog nil
                     l1   (cond
                           ((setq c (cdr c))
                            (editqf (setq com (car c)))
                            (go l1)))))
                   (help (eval c)
                         (setq nopr t)
                         (*** inserted dec 78 by don cohen))
                   (i (setq c
                            (cons (cond ((atom c2) c2) (t (eval c2)))
                                  (mapcar (function
                                           (lambda (x)
                                                   (cond (topflg (print
                                                                  (setq x
                                                                        (eval
                                                                         x)))
                                                                 x)
                                                         (t (eval x)))))
                                          (cddr c))))
                      (setq copyflg nil)
                      (go lp))
                   (if (cond ((and (dtpr (setq tem (edval c2))) (car tem))
                              (cond ((cdr c) (editcoms c3))))
                             ((and (cddr c) (cdddr c)) (editcoms (cadddr c)))
                             (t (err nil)))
                       (setq nopr noprint))
                   (insert
                    (editran c '((before after for) (edit: |#2| |#3| |#1|))))
                   (lc (edloc (cdr c)))
                   (lcl (edlocl (cdr c)))
                   (li (editli c2 (and (cdr c) (car l))))
                   (lo (editlo c2 (and (cdr c) (car l))))
                   ((lp lpq)
                    (edrpt (cdr c) (eq (car c) 'lpq))
                    (setq nopr noprint))
                   (m (cond ((atom c2)
                             (cond ((setq tem (editmac c2 usermacros nil))
                                    (rplacd tem (cddr c)))
                                   (t
                                    (setq usermacros
                                          (cons (cons c2
                                                      (cons nil (cddr c)))
                                                usermacros)))))
                            (t
                             (cond ((setq tem
                                          (editmac (car c2) usermacros t))
                                    (rplaca tem (caddr c))
                                    (rplacd tem (cdddr c)))
                                   (t (nconc editcomsl (ncons (car c2)))
                                      (mark!changed 'editcomsl)
                                      (setq usermacros
                                            (cons (cons (car c2) (cddr c))
                                                  usermacros))))))
                      (mark!changed 'usermacros)
                      (setq nopr t))
                   (makefn
                    (cond ((or (null c2) (null c3) (null (cdddr c)))
                           (err nil))
                          (t
                           (editmakefn c2
                                       c3
                                       (cadddr c)
                                       (cond ((null (cddddr c)) (cadddr c))
                                             (t (car (cddddr c))))))))
                   (mbd (editmbd nil (cdr c)))
                   (move
                    (editran c
                             '((to) (editmv |#1| (car |#3|) (cdr |#3|) nil))))
                   (mv (editmv nil (cadr c) (cddr c) nil))
                   (n (cond ((atom (car l)) (err nil)))
                      (editnconc (car l)
                                 (cond (copyflg (copy (cdr c)))
                                       (t (append (cdr c) nil)))))
                   (nex
                    (setq l
                          ((lambda (l)
                                   (editbelow c2 (cond ((cddr c) c3) (t 1)))
                                   (edit* 1)
                                   l)
                           l)))
                   (nth
                    (cond
                     ((neq (setq tem (editnth (car l) c2)) (car l))
                      (setq l (cons tem l)))))
                   (nx (edit* c2))
                   (orf (edit4f (cons '*any* (cdr c)) 'n))
                   (orr (edor (cdr c)) (setq nopr noprint))
                   (p (cond
                       ((neq lastp1 l) (setq lastp2 lastp1) (setq lastp1 l)))
                      (bpnt (cdr c))
                      (setq nopr t))
                   (r ((lambda (l)
                               (edit4f c2 t)
                               (setq unfind l)
                               (setq c2
                                     (cond ((and (atom c2)
                                                 upfindflg
                                                 (dtpr (car l)))
                                            (caar l))
                                           (t (car l)))))
                       (ncons (car l)))
                      (editdsubst c3 c2 (car l)))
                   (repack (edloc (cdr c)) (editrepack))
                   (replace (editran c '((with by) (edit: : |#1| |#3|))))
                   (ri (editri c2 c3 (and (cdr c) (cddr c) (car l))))
                   (ro (editro c2 (and (cdr c) (car l))))
                   (s (set c2
                           (cond ((null c2) (err nil))
                                 (t ((lambda (l) (edloc (cddr c))) l))))
                      (setq nopr t))
                   (second (edloc (append (cdr c) (cdr c))))
                   (surround (editran c '((with in) (editmbd |#1| |#3|))))
                   (sw (editsw (cadr c) (caddr c)))
                   (third (edloc (append (cdr c) (cdr c) (cdr c))))
                   ((thru to) (editto nil c2 (car c)))
                   (undo (edit!undo topflg nil c2))
                   (xtr (editxtr nil (cdr c)))
                   (_
                    (setq l
                          ((lambda (l)
                                   (prog (uf)
                                         (setq uf l)
                                         (setq c2 (editfpat c2))
                                    lp   (cond ((cond ((and (atom c2)
                                                            (dtpr (car l)))
                                                       (eq c2 (caar l)))
                                                      ((eq (car c2)
                                                           'if)
                                                       (cond ((atom
                                                               (setq tem
                                                                     (edval
                                                                      (cadr
                                                                       c2))))
                                                              nil)
                                                             (t tem)))
                                                      (t
                                                       (edit4e c2
                                                               (cond ((eq (car
                                                                           c2)
                                                                          '@)
                                                                      (caar
                                                                       l))
                                                                     (t
                                                                      (car
                                                                       l))))))
                                                (setq unfind uf)
                                                (return l))
                                               ((setq l (cdr l)) (go lp)))
                                         (err nil)))
                           l)))
                   (cond ((null (setq tem (editmac (car c) usermacros t)))
                          (editdefault c)
                          (setq nopr noprint))
                         ((not (atom (setq c3 (car tem))))
                          (editcoms (subpair c3 (cdr c) (cdr tem)))
                          (setq nopr noprint))
                         (t (editcoms (subst (cdr c) c3 (cdr tem)))
                            (setq nopr noprint))))
          (setq noprint nopr))))

(def editmac
  (lambda (c lst flg)
    (prog (x y)
     lp   (cond ((null lst) (return nil))
                ((eq c (car (setq x (car lst))))
                 (setq y (cdr x))
                 (cond ((cond (flg (car y)) (t (null (car y)))) (return y)))))
          (setq lst (cdr lst))
          (go lp))))

(def editcoms
  (lambda (coms)
    (prog nil
     l1   (cond ((atom coms) (return (car l))))
          (editcom (car coms) nil)
          (setq coms (cdr coms))
          (go l1))))

(def edith
  (lambda (lst)
    (prog nil
          (terpri)
     l1   (cond ((null lst) (return nil))
                ((null (car lst)) (prin1 'block) (go l2))
                ((null (caar lst)) (go l3))
                ((numberp (caar lst))
                 (prin1 (list (caar lst) '--))
                 (go l2)))
          (prin1 (caar lst))
     l2   (princ '" ")
     l3   (setq lst (cdr lst))
          (go l1))))

(def edit!undo
  (lambda (printflg !undoflg undop)
    (prog (lst flg)
          (setq lst undolst)
     lp   (cond ((or (null lst) (null (car lst))) (go out)))
          (cond ((null undop)
                 (selectq (caar lst)
                          ((nil !undo unblock) (go lp1))
                          (undo (cond ((null !undoflg) (go lp1))))
                          nil))
                ((neq undop (caar lst)) (go lp1)))
          (undoeditcom (car lst) printflg)
          (cond ((null !undoflg) (return nil)))
          (setq flg t)
     lp1  (setq lst (cdr lst))
          (go lp)
     out  (cond (flg (return nil))
                ((and lst (cdr lst)) (print 'blocked))
                (t (terpri) (princ '"nothing saved"))))))

(def undoeditcom
  (lambda (x flg)
    (prog (c)
          (cond ((atom x) (err nil))
                ((neq (car (last l)) (car (last (cadr x))))
                 (terpri)
                 (princ '"different expression")
                 (setq com nil)
                 (err nil)))
          (setq c (car x))
          (setq l (cadr x))
          (prog (y z)
                (setq y (cdr x))
           l1   (cond
                 ((setq y (cdr y))
                  (setq z (car y))
                  (cond ((eq (car z) 'r)
                         ((lambda (l)
                                  (editcom (list 'r
                                                 (cadr z)
                                                 (caddr z))
                                           nil))
                          (cadddr z)))
                        (t (editsmash (car z) (cadr z) (cddr z))))
                  (go l1))))
          (editsmash x nil (cons (car x) (cdr x)))
          (and flg
               (setq flg
                     (cond ((not (numberp c)) c) (t (cons c '(--)))))
               (print flg)
               (princ 'undone))
          (return t))))

(def editsmash
  (lambda (old a d)
    (cond ((atom old) (err nil)))
    (setq undolst1 (cons (cons old (cons (car old) (cdr old))) undolst1))
    (rplaca old a)
    (rplacd old d)))

(def editnconc
  (lambda (x y)
    (prog (tem)
          (return
           (cond ((null x) y)
                 ((atom x) (err nil))
                 (t (editsmash (setq tem (last x)) (car tem) y) x))))))

(def editdsubst
  (lambda (x y z)
    (prog nil
     lp   (cond ((atom z) (return nil))
                ((cond ((symbolp y)
                        (or (eq y (car z))
                            (and (stringp (car z)) (eqstr y (car z)))))
                       (t (equal y (car z))))
                 (editsmash z (copy x) (cdr z)))
                (t (editdsubst x y (car z))))
          (cond
           ((and y (eq y (cdr z)))
            (editsmash z (car z) (copy x))
            (return nil)))
          (setq z (cdr z))
          (go lp))))

(def edit1f
  (lambda (c l)
    (cond ((eq c 0) (cond ((null (cdr l)) (err nil)) (t (cdr l))))
          ((atom (car l)) (err nil))
          ((> c 0)
           (cond ((> c (length (car l))) (err nil))
                 (t (cons (car (setq lastail (Cnth (car l) c))) l))))
          ((> (minus c) (length (car l))) (err nil))
          (t
           (cons (car
                  (setq lastail
                        (Cnth (car l) (+ (length (car l)) (add1 c)))))
                 l)))))

(def edit2f
  (lambda (n x)
    (prog (cl)
          (setq cl (car l))
          (cond ((atom cl) (err nil))
                (copyflg (setq x (copy x)))
                (t (setq x (append x nil))))
          (cond ((> n 0)
                 (cond ((> n (length cl)) (err nil))
                       ((null x) (go delete))
                       (t (go replace))))
                ((or (eq n 0) (null x) (> (minus n) (length cl))) (err nil))
                (t (cond ((neq n -1) (setq cl (Cnth cl (minus n)))))
                   (editsmash cl (car x) (cons (car cl) (cdr cl)))
                   (cond
                    ((cdr x)
                     (editsmash cl (car cl) (nconc (cdr x) (cdr cl)))))
                   (return nil)))
     delete
          (cond ((eq n 1)
                 (or (dtpr (cdr cl)) (err nil))
                 (editsmash cl (cadr cl) (cddr cl)))
                (t (setq cl (Cnth cl (sub1 n)))
                   (editsmash cl (car cl) (cddr cl))))
          (return nil)
     replace
          (cond ((neq n 1) (setq cl (Cnth cl n))))
          (editsmash cl (car x) (cdr cl))
          (cond ((cdr x) (editsmash cl (car cl) (nconc (cdr x) (cdr cl))))))))

(def edit4e
  (lambda (pat y)
    (cond ((eq pat y) t)
          ((atom pat)
           (or (eq pat '&)
               (equal pat y)
               (and (stringp y) (stringp pat) (eqstr pat y))))
          ((eq (car pat) '*any*)
           (prog nil
            lp   (cond ((null (setq pat (cdr pat))) (return nil))
                       ((edit4e (car pat) y) (return t)))
                 (go lp)))
          ((and (eq (car pat) '@) (atom y))
           (prog (z)
                 (setq pat (cdr pat))
                 (setq z (explodec y))
            lp   (cond ((eq (car pat) '@)
                        (*** freelist z)
                        (print '=)
                        (prin1 y)
                        (return t))
                       ((null z) (return nil))
                       ((neq (car pat) (car z))
                        (*** freelist z)
                        (return nil)))
                 (setq pat (cdr pat))
                 (setq z (cdr z))
                 (go lp)))
          ((eq (car pat) '--)
           (or (null (setq pat (cdr pat)))
               (prog nil
                lp   (cond ((edit4e pat y) (return t))
                           ((atom y) (return nil)))
                     (setq y (cdr y))
                     (go lp))))
          ((eq (car pat) '==) (eq (cdr pat) y))
          ((atom y) nil)
          ((edit4e (car pat) (car y)) (edit4e (cdr pat) (cdr y))))))

(def editqf
  (lambda (pat)
    (prog (q1)
          (cond ((and (dtpr (car l))
                      (dtpr (setq q1 (cdar l)))
                      (setq q1 (memq pat q1)))
                 (setq l
                       (cons (cond (upfindflg q1)
                                   (t (setq lastail q1) (car q1)))
                             l)))
                (t (edit4f pat 'n))))))

(def edit4f
  (lambda (pat %%x)
    (prog (ll x %%w)
          (setq %%w (ncons nil))
          (setq com pat)
          (setq pat (editfpat pat))
          (setq ll l)
          (cond
           ((eq %%x 'n)
            (setq %%x 1)
            (cond ((atom (car l)) (go lp1))
                  ((and (atom (caar l)) upfindflg)
                   (setq ll (cons (caar l) l))
                   (go lp1))
                  (t (setq ll (cons (caar l) l))))))
          (cond ((and %%x (not (numberp %%x))) (setq %%x 1)))
          (cond
           ((and (edit4e (cond ((and (dtpr pat) (eq (car pat) ':::))
                                (cdr pat))
                               (t pat))
                         (car ll))
                 (or (null %%x) (eq (setq %%x (sub1 %%x)) 0)))
            (return (setq l ll))))
          (setq x (car ll))
     lp   (cond ((edit4f1 pat x maxlevel)
                 (and (cdr l) (setq unfind l))
                 (return
                  (car
                   (setq l
                         (nconc (car %%w)
                                (cond ((eq (cadr %%w) (car ll)) (cdr ll))
                                      (t ll)))))))
                ((null %%x) (err nil)))
     lp1  (setq x (car ll))
          (cond ((null (setq ll (cdr ll))) (err nil))
                ((and (setq x (memq x (car ll))) (dtpr (setq x (cdr x))))
                 (go lp)))
          (go lp1))))

(def editfpat
  (lambda (pat)
    (cond ((dtpr pat)
           (cond ((or (eq (car pat) '==) (eq (car pat) '@)) pat)
                 (t (mapcar (function editfpat) pat))))
          ((eq (nthchar pat -1) '@) (cons '@ (explodec pat)))
          (t pat))))

(def edit4f1
  (lambda (pat x lvl)
    (prog nil
     lp   (cond ((not (> lvl 0))
                 (terpri)
                 (princ '"maxlevel exceeded")
                 (return nil))
                ((atom x) (return nil))
                ((and (dtpr pat)
                      (eq (car pat) ':::)
                      (edit4e (cdr pat) x)
                      (or (null %%x) (eq (setq %%x (sub1 %%x)) 0))))
                ((and (or (atom pat) (neq (car pat) ':::))
                      (edit4e pat (car x))
                      (or (null %%x) (eq (setq %%x (sub1 %%x)) 0)))
                 (cond
                  ((or (null upfindflg) (dtpr (car x)))
                   (setq lastail x)
                   (setq x (car x)))))
                ((and pat
                      (eq pat (cdr x))
                      (or (null %%x) (eq (setq %%x (sub1 %%x)) 0)))
                 (setq x (cdr x)))
                ((and %%x
                      (dtpr (car x))
                      (edit4f1 pat (car x) (sub1 lvl))
                      (eq %%x 0))
                 (setq x (car x)))
                (t (setq x (cdr x)) (setq lvl (sub1 lvl)) (go lp)))
          (cond ((and %%w (neq x (cadr %%w))) (tconc %%w x)))
          (return (or %%w t)))))

(def editfindp
  (lambda (x pat flg)
    (prog (%%x lastail %%w)
          (setq %%x 1)
          (and (null flg) (setq pat (editfpat pat)))
          (return (or (edit4e pat x) (edit4f1 pat x maxlevel))))))

(def editbf
  (lambda (pat n)
    (prog (ll x y %%w)
          (setq ll l)
          (setq %%w (ncons nil))
          (setq com pat)
          (setq pat (editfpat pat))
          (cond ((and (null n) (cdr ll)) (go lp1)))
     lp   (cond
           ((editbf1 pat (car ll) maxlevel y)
            (setq unfind l)
            (return
             (car
              (setq l
                    (nconc (car %%w)
                           (cond ((eq (car ll) (cadr %%w)) (cdr ll))
                                 (t ll))))))))
     lp1  (setq x (car ll))
          (cond ((null (setq ll (cdr ll))) (err nil))
                ((or (setq y (memq x (car ll))) (setq y (tailp x (car ll))))
                 (go lp)))
          (go lp1))))

(def editbf1
  (lambda (pat x lvl tail)
    (prog (y)
     lp   (cond ((not (> lvl 0))
                 (terpri)
                 (princ '"maxlevel exceeded")
                 (return nil))
                ((eq tail x)
                 (return
                  (cond
                   ((edit4e (cond ((and (dtpr pat)
                                        (eq (car pat) ':::))
                                   (cdr pat))
                                  (t pat))
                            x)
                    (tconc %%w x))))))
          (setq y x)
     lp1  (cond
           ((null (or (eq (cdr y) tail) (atom (cdr y))))
            (setq y (cdr y))
            (go lp1)))
          (setq tail y)
          (cond ((and (dtpr (car tail))
                      (editbf1 pat (car tail) (sub1 lvl) nil))
                 (setq tail (car tail)))
                ((and (dtpr pat)
                      (eq (car pat) ':::)
                      (edit4e (cdr pat) tail)))
                ((and (or (atom pat) (neq (car pat) ':::))
                      (edit4e pat (car tail)))
                 (cond
                  ((or (null upfindflg) (dtpr (car tail)))
                   (setq lastail tail)
                   (setq tail (car tail)))))
                ((and pat (eq pat (cdr tail))) (setq x (cdr x)))
                (t (setq lvl (sub1 lvl)) (go lp)))
          (cond ((neq tail (cadr %%w)) (tconc %%w tail)))
          (return %%w))))

(def editnth
  (lambda (x n)
    (cond ((atom x) (err nil))
          ((not (numberp n))
           (or (memq n x) (memq (setq n (editelt n (ncons x))) x) (tailp n x)))
          ((eq n 0) (err nil))
          ((null
            (setq n
                  (cond
                   ((or (not (minusp n))
                        (> (setq n (plus (length x) n 1)) 0))
                    (Cnth x n)))))
           (err nil))
          (t n))))

(def bpnt0
  (lambda (y n)
    (cond ((neq lastp1 l) (setq lastp2 lastp1) (setq lastp1 l)))
    (cond (n (setq $%dotflg (tailp (car l) (cadr l)))
             (setq %prevfn% '" ")
             (printlev y n))
          (t (terpri) (*** sprint y 1) ($prpr y) (terpri)))))

(def bpnt
  (lambda (x)
    (prog (y n)
          (cond ((eq (car x) 0)
                 (setq y (car l))
                 (setq $%dotflg (tailp (car l) (cadr l))))
                (t (setq y (car (editnth (car l) (car x))))))
          (cond ((null (cdr x)) (setq n 2))
                ((not (numberp (setq n (cadr x)))) (err nil))
                ((minusp n) (err nil)))
          (setq %prevfn% '" ")
          (return (printlev y n)))))

(def editri
  (lambda (m n x)
    (prog (a b)
          (setq a (editnth x m))
          (setq b (editnth (car a) n))
          (cond ((or (null a) (null b)) (err nil)))
          (editsmash a (car a) (editnconc (cdr b) (cdr a)))
          (editsmash b (car b) nil))))

(def editro
  (lambda (n x)
    (setq x (editnth x n))
    (cond ((or (null x) (atom (car x))) (err nil)))
    (editsmash (setq n (last (car x))) (car n) (cdr x))
    (editsmash x (car x) nil)))

(def editli
  (lambda (n x)
    (setq x (editnth x n))
    (cond ((null x) (err nil)))
    (editsmash x (cons (car x) (cdr x)) nil)))

(def editlo
  (lambda (n x)
    (setq x (editnth x n))
    (cond ((or (null x) (atom (car x))) (err nil)))
    (editsmash x (caar x) (cdar x))))

(def editbi
  (lambda (m n x)
    (prog (a b)
          (setq b (cdr (setq a (editnth x n))))
          (setq x (editnth x m))
          (cond ((and a (not (> (length a) (length x))))
                 (editsmash a (car a) nil)
                 (editsmash x (cons (car x) (cdr x)) b))
                (t (err nil))))))

(def editbo
  (lambda (n x)
    (setq x (editnth x n))
    (cond ((atom (car x)) (err nil)))
    (editsmash x (caar x) (editnconc (cdar x) (cdr x)))))

(def editdefault
  (lambda (editx)
    (prog nil
          (cond (lcflg
                 (return
                  (cond ((eq lcflg t) (editqf editx))
                        (t (editcom (list lcflg editx) topflg)))))
                ((null topflg) (err nil))
                ((memq editx editcomsl)
                 (cond (readbuf (setq editx (cons editx readbuf))
                                (setq readbuf nil))
                       (t (err nil))))
                (t (err nil)))
          (return (editcom (setq com editx) topflg)))))

(def edup
  (lambda nil
    (prog (c-exp l1 x y)
          (setq c-exp (car l))
     lp   (cond ((null (setq l1 (cdr l))) (err nil))
                ((tailp c-exp (car l1)) (return nil))
                ((not (setq x (memq c-exp (car l1)))) (err nil))
                ((or (eq x lastail) (not (setq y (memq c-exp (cdr x))))))
                ((and (eq c-exp (car lastail)) (tailp lastail y))
                 (setq x lastail))
                (t (terpri)
                   (princ c-exp)
                   (princ '"- location uncertain")))
          (cond ((eq x (car l1)) (setq l l1)) (t (setq l (cons x l1))))
          (return nil))))

(def edit*l
  (lambda (l)
    (edup)
    (length (car l))))

(def edit*
  (lambda (n)
    (car
     (setq l
           ((lambda (com l m)
                    (cond ((not (> m n)) (err nil)))
                    (edit!0)
                    (edit1f (difference n m) l))
            nil
            l
            (edit*l l))))))

(def edor
  (lambda (coms)
    (prog nil
     lp   (cond ((null coms) (err nil))
                ((dtpr
                  (errset
                   (setq l
                         ((lambda (l)
                                  (cond ((atom (car coms))
                                         (editcom (car coms) nil))
                                        (t (editcoms (car coms))))
                                  l)
                          l))))
                 (return (car l))))
          (setq coms (cdr coms))
          (go lp))))

(def errcom
  (lambda (coms)
    (errset (editcoms coms))))

(def edrpt
  (lambda (edrx quiet)
    (prog (edrl edrptcnt)
          (setq edrl l)
          (setq edrptcnt 0)
     lp   (cond ((> edrptcnt maxloop)
                 (terpri)
                 (princ '"maxloop exceeded"))
                ((dtpr (errcom edrx))
                 (setq edrl l)
                 (setq edrptcnt (add1 edrptcnt))
                 (go lp))
                ((null quiet) (print edrptcnt) (princ 'occurrences)))
          (setq l edrl))))

(def edloc
  (lambda (edx)
    (prog (oldl oldf lcflg edl)
          (setq oldl l)
          (setq oldf unfind)
          (setq lcflg t)
          (cond ((atom edx) (editcom edx nil))
                ((and (null (cdr edx)) (atom (car edx)))
                 (editcom (car edx) nil))
                (t (go lp)))
          (setq unfind oldl)
          (return (car l))
     lp   (setq edl l)
          (cond ((dtpr (errcom edx)) (setq unfind oldl) (return (car l))))
          (cond ((equal edl l) (setq l oldl) (setq unfind oldf) (err nil)))
          (go lp))))

(def edlocl
  (lambda (coms)
    (car
     (setq l
           (nconc ((lambda (l unfind) (edloc coms) l) (ncons (car l)) nil)
                  (cdr l))))))

(def edit:
  (lambda (type lc x)
    (prog (toflg l0)
          (setq l0 l)
          (setq x
                (mapcar (function
                         (lambda (x)
                                 (cond ((and (dtpr x)
                                             (eq (car x) '|##|))
                                        ((lambda (l undolst1)
                                                 (copy (editcoms (cdr x))))
                                         l
                                         nil))
                                       (t x))))
                        x))
          (cond
           (lc (cond ((eq (car lc) 'here) (setq lc (cdr lc))))
               (edloc lc)))
          (edup)
          (cond ((eq l0 l) (setq lc nil)))
          (selectq type
                   ((b before) (edit2f -1 x))
                   ((a after)
                    (cond ((cdar l) (edit2f -2 x))
                          (t (editcoml (cons 'n x) copyflg))))
                   ((: for)
                    (cond ((or x (cdar l)) (edit2f 1 x))
                          ((memq (car l) (cadr l))
                           (edup)
                           (edit2f 1 (ncons nil)))
                          (t (editcoms '(0 (nth -2) (2)))))
                    (return (cond ((null lc) l))))
                   (err nil))
          (return nil))))

(def editmbd
  (lambda (lc x)
    (prog (y toflg)
          (cond (lc (edloc lc)))
          (edup)
          (setq y (cond (toflg (caar l)) (t (ncons (caar l)))))
          (edit2f 1
                  (ncons
                   (cond ((or (atom (car x)) (cdr x)) (append x y))
                         (t (lsubst y '* (car x))))))
          (setq l
                (cons (caar l)
                      (cond ((tailp (car l) (cadr l)) (cdr l)) (t l))))
          (return (cond ((null lc) l))))))

(def editxtr
  (lambda (lc x)
    (prog (toflg)
          (cond (lc (edloc lc)))
          ((lambda (l unfind)
                   (edloc x)
                   (setq x
                         (cond ((tailp (car l) (cadr l)) (caar l))
                               (t (car l)))))
           (ncons (cond ((tailp (car l) (cadr l)) (caar l)) (t (car l))))
           nil)
          (edup)
          (edit2f 1 (cond (toflg (append x nil)) (t (ncons x))))
          (and (null toflg)
               (dtpr (caar l))
               (setq l
                     (cons (caar l)
                           (cond ((tailp (car l) (cadr l)) (cdr l)) (t l))))))))

(def editelt
  (lambda (lc l)
    (prog (y)
          (edloc lc)
     lp   (setq y l)
          (cond ((cdr (setq l (cdr l))) (go lp)))
          (return (car y)))))

(def editcont
  (lambda (lc1 %%x)
    (setq l
          ((lambda (l)
                   (prog nil
                         (setq lc1 (editfpat lc1))
                    lp   (cond ((null (edit4f lc1 'n)) (err nil))
                               ((atom (errset (edlocl %%x))) (go lp)))
                    lp1  (cond ((null (setq l (cdr l))) (err nil))
                               ((cond ((atom lc1) (eq lc1 (caar l)))
                                      ((eq (car lc1) '@)
                                       (edit4e lc1 (caar l)))
                                      (t (edit4e lc1 (car l))))
                                (return l)))
                         (go lp1)))
           l))))

(def editsw
  (lambda (m n)
    (prog (y z tem)
          (setq y (editnth (car l) m))
          (setq z (editnth (car l) n))
          (setq tem (car y))
          (editsmash y (car z) (cdr y))
          (editsmash z tem (cdr z)))))

(def editmv
  (lambda (lc op x cp)
    (prog (l0 l1 z toflg)
          (setq l0 l)
          (and lc (edloc lc))
          (cond ((eq op 'here)
                 (cond ((null lc) (edloc x) (setq x nil)))
                 (setq op ':))
                ((eq (car x) 'here)
                 (cond ((null lc) (edloc (cdr x)) (setq x nil))
                       (t (setq x (cdr x))))))
          (edup)
          (setq l1 l)
          (setq z (cond (cp (copy (caar l))) (t (caar l))))
          (setq l l0)
          (and x (edloc x))
          (cond ((eq op 'after) (setq op 'a))
                ((eq op 'before) (setq op 'b)))
          (editcoml (cond (toflg (cons op (append z nil))) (t (list op z)))
                    nil)
          (prog (l)
                (setq l l1)
                (cond ((not cp) (editcoms '(1 delete)))
                      (toflg (editcoml '(bo 1) nil))))
          (return
           (cond ((null lc) (setq unfind l1) l)
                 ((null x) (setq unfind l1) l0)
                 (t (setq unfind l) l0))))))

(def editto
  (lambda (lc1 lc2 flg)
    (setq l
          ((lambda (l)
                   (cond (lc1 (edloc lc1) (edup)))
                   (editbi 1
                           (cond ((and (numberp lc1)
                                       (numberp lc2)
                                       (> lc2 lc1))
                                  (difference (add1 lc2) lc1))
                                 (t lc2))
                           (car l))
                   (cond
                    ((and (eq flg 'to) (cdaar l))
                     (editri 1 -2 (car l))))
                   (editcom 1 nil)
                   l)
           l))
    (setq toflg t)))

(def editbelow
  (lambda (place depth)
    (cond ((minusp (setq depth (eval depth))) (err nil)))
    (prog (n1 n2)
          (setq n1
                (length
                 ((lambda (l lcflg) (editcom place nil) l) l '_)))
          (setq n2 (length l))
          (cond ((< n2 (+ n1 depth)) (err nil)))
          (setq unfind l)
          (setq l (Cnth l (difference (add1 n2) n1 depth))))))

(def editran
  (lambda (c def)
    (setq l
          (or ((lambda (l)
                       (prog (z w)
                             (cond ((null def) (err nil))
                                   ((null (setq z (car def))) (go out)))
                        lp   (cond ((null z) (err nil))
                                   ((null (setq w (memq (car z) c)))
                                    (setq z (cdr z))
                                    (go lp)))
                        out  (setq z
                                   (apply (car (setq def (cadr def)))
                                          (prog (|#1| |#2| |#3|)
                                                (setq |#1| (cdr
                                                            (ldiff c w)))
                                                (setq |#2| (car z))
                                                (setq |#3| (cdr w))
                                                (return
                                                 (mapcar (function
                                                          (lambda (x)
                                                                  (cond ((atom
                                                                          x)
                                                                         (selectq x
                                                                                  (|#1|
                                                                                   |#1|)
                                                                                  (|#2|
                                                                                   |#2|)
                                                                                  (|#3|
                                                                                   |#3|)
                                                                                  x))
                                                                        (t
                                                                         (eval
                                                                          x)))))
                                                         (cdr def))))))
                             (return
                              (cond ((null z) (setq unfind l) nil) (t z)))))
               l)
              l))))

(def edit!0
  (lambda nil
    (cond ((null (cdr l)) (err nil)))
    (prog nil
     lp   (setq l (cdr l))
          (cond ((tailp (car l) (cadr l)) (go lp))))))

(def editrepack
  (lambda nil
    (cond ((dtpr (car l)) (setq l (edit1f 1 l))))
    (edit: ': nil (ncons (readlist (edite (explode (car l)) nil nil))))))

(def editmakefn
  (lambda (ex args n m)
    (editbi n m (car l))
    (edloc n)
    (editbelow '/ 1)
    (mapc (function (lambda (x y) (editdsubst x y (car l)))) args (cdr ex))
    (putprop (car ex) (cons 'lambda (cons args (car l))) 'expr)
    (mark!changed (car ex))
    (edup)
    (edit2f 1 (ncons ex))))

(dv usermacros nil)

(dv editracefn nil)

(dv lastword editsfns)

(dv maxlevel 192)

(dv maxloop 24)

(dv editcomsl
    (: a
       b
       below
       bf
       bi
       bind
       bk
       bo
       change
       coms
       comsq
       copy
       cp
       delete
       e
       embed
       extract
       f
       f=
       fs
       help
       i
       if
       insert
       lc
       lcl
       li
       lo
       lp
       lpq
       m
       makefn
       mbd
       move
       mv
       n
       nex
       nth
       nx
       orf
       orr
       p
       r
       repack
       replace
       ri
       ro
       s
       second
       surround
       sw
       third
       thru
       to
       undo
       xtr
       _))

(dv autop 2)

(dv upfindflg t)
