"$Header: /usr/lib/lisp/cmuedit.l,v 1.1 83/01/29 18:33:36 jkf Exp $")
(eval-when (compile load eval) (load 'cmumacs) (load 'cmufncs))
(declare (special c2 c3 tem nopr %changes))
(declare (*expr editracefn))
(declare (special c nopr)) ; LWE 1/11/80 Hacks for new compiler.
((lambda (l undolst1) (editcoms coms)) l nil)))
(cons 'editf (cons (car y) (cdr x)))))
(setq x (ncons lastword))))
(cond ((*** setq y (get fn 'trace)) (setq fn (cdr y))))
(cond ((setq y (getd fn))
(edite y (cdr x) (car x))
(*** 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))
(putprop (car x) fn y)))))
(return (setq lastword (car x))))
((and (boundp fn) (dtpr (cdr y))) (go l1))))
((dtpr (car x)) (go l1)))
(return (eval (cons 'editv x))))))
(setq x (ncons lastword))))
(cond ((dtpr (car x)) (edite (eval (car x)) (cdr x) nil) (return t))
(edite y (cdr x) (car x))
(return (setq lastword (car x))))
(t (print (car x)) (princ '" not editable") (err nil))))))
((null x) (print '=) (prin1 lastword) (setq x (ncons lastword))))
(cond ((dtpr (car x)) (print '=editv) (eval (cons 'editv x)))
(edite (plist (car x)) (cdr x) (car x))
(t (print (car x)) (princ '" not editable") (err nil)))))
(cond ((atom expr) (print expr) (princ '" not editable") (err nil))
(t (car (last (editl (ncons expr) coms atm nil nil)))))))
(lambda (l coms atm marklst mess)
(prog (com lastail undolst undolst1 findflag lcflg unfind lastp1 lastp2 readbuf l0 com0 oldprompt upfindflg noprint findarg)
(cond ((dtpr (setq l (catch (eval '(editl0)) edit-abort)))
(cond ((eq (car coms) 'start)
(setq readbuf (append (cdr coms) (list nil)))
(*** don 't quit if command fails))
(t (editcoms (append coms (list 'ok))) (return l)))))
((or (null coms) (eq (car coms) 'start))
(print (or mess 'edit))))
(setq marklst (cadr com))
(setq undolst (caddr com))
(cond ((car undolst) (setq undolst (cons nil undolst))))
(setq unfind (cdddr com))))
(cons (sub1 (stkcount 'editl0 (add1 (spdlpt)) 0))
((and autop (null readbuf) (not noprint)) (bpnt (list 0 autop))))
(setq com0 (cond ((atom com) com) (t (car com))))
(prog1 (errset (editcom com t))
(cons com0 (cons l0 undolst1)))
(setq undolst (cons undolst1 undolst))))))
(cond (com (prin1 com) (princ '" ?") (terpri)))
((neq (car oldprompt) 0) (princ (car oldprompt))))
((atom (setq readbuf (errset (lineread))))
(setq readbuf (car readbuf)))))
(setq readbuf (cdr readbuf))
(declare (*expr editracefn))
(cond (editracefn (editracefn c)))
(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))))
(eval (cons 'help readbuf))
(*** inserted dec 78 by don cohen))
lp (cond ((or (null (setq l (cdr l)))
(!undo (edit!undo t t nil))
(? (bpnt0 (car l) 64) (setq nopr t))
(?? (edith undolst) (setq nopr t))
(delete (setq c '(delete)) (edit: ': nil nil))
(mark (setq marklst (cons l marklst)) (setq nopr t))
((lambda (l) (editbelow '_ 1) (edit* 1) l)
(cond ((null topflg) (setq findflag c))
(bf (editbf findarg nil))
((and (dtpr undolst) (car undolst))
(remprop atm 'edit-save)))
(cons (last l) (cons marklst (cons undolst l)))
(*** prompt (cdr oldprompt))
(p (bpnt0 (car l) 2) (setq nopr t))
(pp (bpnt0 (car l) nil) (setq nopr t))
(pp* ((lambda (commentflg) (bpnt0 (car l) nil)) t)
((and (dtpr undolst) (car undolst))
(*** prompt (cdr oldprompt))
(stop (*** prompt (cdr oldprompt))
(stksrch 'editl0 (spdlpt) nil)
(test (setq undolst (cons nil undolst)) (setq nopr t))
(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")))
(undo (edit!undo topflg nil (cond (readbuf (editread)))))
(and (cdr c) (setq unfind c)))
(cond ((and lastp1 (neq lastp1 l)) (setq l lastp1))
((and lastp2 (neq lastp2 l)) (setq l lastp2))
(^ (and (cdr l) (setq unfind l)) (setq l (last l)))
(cond (marklst (and (cdr l) (setq unfind l))
(setq marklst (cdr marklst))))
(tl (top-level) (setq nopr t))
(cond ((null (setq tem (editmac c usermacros nil)))
(t (editcoms (copy (cdr tem))) (setq nopr noprint))))
(cond ((dtpr (cddr c)) (setq c3 (caddr c)))
(t (setq c2 (setq c3 nil))))
(editcont (car c) (cddr c))
((a b :) (edit: (car c) nil (cdr c)))
(below (editbelow c2 (cond ((cddr c) c3) (t 1))))
(cond ((cddr c) c3) (t c2))
(bind (prog (|#1| |#2| |#3|)
(bo (editbo c2 (and (cdr c) (car l))))
(change (editran c '((to) (edit: : |#1| |#3|))))
(editcom (setq com (eval (car c))) nil)
(comsq (editcoms (cdr c)) (setq nopr noprint))
(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))))
(cond ((null (cddr c)) (print tem)))
(embed (editran c '((in with) (editmbd |#1| |#3|))))
(extract (editran c '((from) (editxtr |#3| |#1|))))
(f= (edit4f (cons '== c2) c3))
(editqf (setq com (car c)))
(*** inserted dec 78 by don cohen))
(cons (cond ((atom c2) c2) (t (eval c2)))
(if (cond ((and (dtpr (setq tem (edval c2))) (car tem))
(cond ((cdr c) (editcoms c3))))
((and (cddr c) (cdddr c)) (editcoms (cadddr c)))
(editran c '((before after for) (edit: |#2| |#3| |#1|))))
(li (editli c2 (and (cdr c) (car l))))
(lo (editlo c2 (and (cdr c) (car l))))
(edrpt (cdr c) (eq (car c) 'lpq))
(cond ((setq tem (editmac c2 usermacros nil))
(editmac (car c2) usermacros t))
(t (nconc editcomsl (ncons (car c2)))
(mark!changed 'editcomsl)
(cons (cons (car c2) (cddr c))
(mark!changed 'usermacros)
(cond ((or (null c2) (null c3) (null (cdddr c)))
(cond ((null (cddddr c)) (cadddr c))
(t (car (cddddr c))))))))
(mbd (editmbd nil (cdr c)))
'((to) (editmv |#1| (car |#3|) (cdr |#3|) nil))))
(mv (editmv nil (cadr c) (cddr c) nil))
(n (cond ((atom (car l)) (err nil)))
(cond (copyflg (copy (cdr c)))
(t (append (cdr c) nil)))))
(editbelow c2 (cond ((cddr c) c3) (t 1)))
((neq (setq tem (editnth (car l) c2)) (car l))
(orf (edit4f (cons '*any* (cdr c)) 'n))
(orr (edor (cdr c)) (setq nopr noprint))
((neq lastp1 l) (setq lastp2 lastp1) (setq lastp1 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))))
(cond ((null c2) (err nil))
(t ((lambda (l) (edloc (cddr c))) l))))
(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)))
lp (cond ((cond ((and (atom c2)
((setq l (cdr l)) (go lp)))
(cond ((null (setq tem (editmac (car c) usermacros t)))
((not (atom (setq c3 (car tem))))
(editcoms (subpair c3 (cdr c) (cdr tem)))
(t (editcoms (subst (cdr c) c3 (cdr tem)))
lp (cond ((null lst) (return nil))
((eq c (car (setq x (car lst))))
(cond ((cond (flg (car y)) (t (null (car y)))) (return y)))))
l1 (cond ((atom coms) (return (car l))))
l1 (cond ((null lst) (return nil))
((null (car lst)) (prin1 'block) (go l2))
((null (caar lst)) (go l3))
(prin1 (list (caar lst) '--))
(lambda (printflg !undoflg undop)
lp (cond ((or (null lst) (null (car lst))) (go out)))
((nil !undo unblock) (go lp1))
(undo (cond ((null !undoflg) (go lp1))))
((neq undop (caar lst)) (go lp1)))
(undoeditcom (car lst) printflg)
(cond ((null !undoflg) (return nil)))
out (cond (flg (return nil))
((and lst (cdr lst)) (print 'blocked))
(t (terpri) (princ '"nothing saved"))))))
(cond ((atom x) (err nil))
((neq (car (last l)) (car (last (cadr x))))
(princ '"different expression")
(t (editsmash (car z) (cadr z) (cddr z))))
(editsmash x nil (cons (car x) (cdr x)))
(cond ((not (numberp c)) c) (t (cons c '(--)))))
(cond ((atom old) (err nil)))
(setq undolst1 (cons (cons old (cons (car old) (cdr old))) undolst1))
(t (editsmash (setq tem (last x)) (car tem) y) x))))))
lp (cond ((atom z) (return nil))
(and (stringp (car z)) (eqstr y (car z)))))
(editsmash z (copy x) (cdr z)))
(t (editdsubst x y (car z))))
(editsmash z (car z) (copy x))
(cond ((eq c 0) (cond ((null (cdr l)) (err nil)) (t (cdr l))))
((atom (car l)) (err nil))
(cond ((> c (length (car l))) (err nil))
(t (cons (car (setq lastail (Cnth (car l) c))) l))))
((> (minus c) (length (car l))) (err nil))
(Cnth (car l) (+ (length (car l)) (add1 c)))))
(cond ((atom cl) (err nil))
(copyflg (setq x (copy x)))
(t (setq x (append x nil))))
(cond ((> n (length cl)) (err nil))
((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)))
(editsmash cl (car cl) (nconc (cdr x) (cdr cl)))))
(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))))
(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))))))))
(and (stringp y) (stringp pat) (eqstr pat y))))
lp (cond ((null (setq pat (cdr pat))) (return nil))
((edit4e (car pat) y) (return t)))
((and (eq (car pat) '@) (atom y))
lp (cond ((eq (car pat) '@)
(or (null (setq pat (cdr pat)))
lp (cond ((edit4e pat y) (return t))
((eq (car pat) '==) (eq (cdr pat) y))
((edit4e (car pat) (car y)) (edit4e (cdr pat) (cdr y))))))
(cond ((and (dtpr (car l))
(dtpr (setq q1 (cdar l)))
(cons (cond (upfindflg q1)
(t (setq lastail q1) (car q1)))
(setq pat (editfpat pat))
(cond ((atom (car l)) (go lp1))
((and (atom (caar l)) upfindflg)
(setq ll (cons (caar l) l))
(t (setq ll (cons (caar l) l))))))
(cond ((and %%x (not (numberp %%x))) (setq %%x 1)))
((and (edit4e (cond ((and (dtpr pat) (eq (car pat) ':::))
(or (null %%x) (eq (setq %%x (sub1 %%x)) 0)))
lp (cond ((edit4f1 pat x maxlevel)
(and (cdr l) (setq unfind l))
(cond ((eq (cadr %%w) (car ll)) (cdr ll))
(cond ((null (setq ll (cdr ll))) (err nil))
((and (setq x (memq x (car ll))) (dtpr (setq x (cdr x))))
(cond ((or (eq (car pat) '==) (eq (car pat) '@)) pat)
(t (mapcar (function editfpat) pat))))
((eq (nthchar pat -1) '@) (cons '@ (explodec pat)))
lp (cond ((not (> lvl 0))
(princ '"maxlevel exceeded")
(or (null %%x) (eq (setq %%x (sub1 %%x)) 0))))
((and (or (atom pat) (neq (car pat) ':::))
(or (null %%x) (eq (setq %%x (sub1 %%x)) 0)))
((or (null upfindflg) (dtpr (car x)))
(or (null %%x) (eq (setq %%x (sub1 %%x)) 0)))
(edit4f1 pat (car x) (sub1 lvl))
(t (setq x (cdr x)) (setq lvl (sub1 lvl)) (go lp)))
(cond ((and %%w (neq x (cadr %%w))) (tconc %%w x)))
(and (null flg) (setq pat (editfpat pat)))
(return (or (edit4e pat x) (edit4f1 pat x maxlevel))))))
(setq pat (editfpat pat))
(cond ((and (null n) (cdr ll)) (go lp1)))
((editbf1 pat (car ll) maxlevel y)
(cond ((eq (car ll) (cadr %%w)) (cdr ll))
(cond ((null (setq ll (cdr ll))) (err nil))
((or (setq y (memq x (car ll))) (setq y (tailp x (car ll))))
lp (cond ((not (> lvl 0))
(princ '"maxlevel exceeded")
((edit4e (cond ((and (dtpr pat)
((null (or (eq (cdr y) tail) (atom (cdr y))))
(cond ((and (dtpr (car tail))
(editbf1 pat (car tail) (sub1 lvl) nil))
(edit4e (cdr pat) tail)))
((and (or (atom pat) (neq (car pat) ':::))
((or (null upfindflg) (dtpr (car 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)))
(cond ((atom x) (err nil))
(or (memq n x) (memq (setq n (editelt n (ncons x))) x) (tailp n x)))
(> (setq n (plus (length x) n 1)) 0))
(cond ((neq lastp1 l) (setq lastp2 lastp1) (setq lastp1 l)))
(cond (n (setq $%dotflg (tailp (car l) (cadr l)))
(t (terpri) (*** sprint y 1) ($prpr y) (terpri)))))
(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))
(return (printlev y n)))))
(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))))
(cond ((or (null x) (atom (car x))) (err nil)))
(editsmash (setq n (last (car x))) (car n) (cdr x))
(editsmash x (car x) nil)))
(cond ((null x) (err nil)))
(editsmash x (cons (car x) (cdr x)) nil)))
(cond ((or (null x) (atom (car x))) (err nil)))
(editsmash x (caar x) (cdar x))))
(setq b (cdr (setq a (editnth x n))))
(cond ((and a (not (> (length a) (length x))))
(editsmash a (car a) nil)
(editsmash x (cons (car x) (cdr x)) b))
(cond ((atom (car x)) (err nil)))
(editsmash x (caar x) (editnconc (cdar x) (cdr x)))))
(cond ((eq lcflg t) (editqf editx))
(t (editcom (list lcflg editx) topflg)))))
((null topflg) (err nil))
(cond (readbuf (setq editx (cons editx readbuf))
(return (editcom (setq com editx) topflg)))))
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))
(princ '"- location uncertain")))
(cond ((eq x (car l1)) (setq l l1)) (t (setq l (cons x l1))))
(cond ((not (> m n)) (err nil)))
(edit1f (difference n m) l))
lp (cond ((null coms) (err nil))
(editcom (car coms) nil))
(t (editcoms (car coms))))
(errset (editcoms coms))))
lp (cond ((> edrptcnt maxloop)
(princ '"maxloop exceeded"))
(setq edrptcnt (add1 edrptcnt))
((null quiet) (print edrptcnt) (princ 'occurrences)))
(prog (oldl oldf lcflg edl)
(cond ((atom edx) (editcom edx nil))
((and (null (cdr edx)) (atom (car edx)))
(cond ((dtpr (errcom edx)) (setq unfind oldl) (return (car l))))
(cond ((equal edl l) (setq l oldl) (setq unfind oldf) (err nil)))
(nconc ((lambda (l unfind) (edloc coms) l) (ncons (car l)) nil)
(copy (editcoms (cdr x))))
(lc (cond ((eq (car lc) 'here) (setq lc (cdr lc))))
(cond ((eq l0 l) (setq lc nil)))
((b before) (edit2f -1 x))
(cond ((cdar l) (edit2f -2 x))
(t (editcoml (cons 'n x) copyflg))))
(cond ((or x (cdar l)) (edit2f 1 x))
(t (editcoms '(0 (nth -2) (2)))))
(return (cond ((null lc) l))))
(setq y (cond (toflg (caar l)) (t (ncons (caar l)))))
(cond ((or (atom (car x)) (cdr x)) (append x y))
(t (lsubst y '* (car x))))))
(cond ((tailp (car l) (cadr l)) (cdr l)) (t l))))
(return (cond ((null lc) l))))))
(cond ((tailp (car l) (cadr l)) (caar l))
(ncons (cond ((tailp (car l) (cadr l)) (caar l)) (t (car l))))
(edit2f 1 (cond (toflg (append x nil)) (t (ncons x))))
(cond ((tailp (car l) (cadr l)) (cdr l)) (t l))))))))
(cond ((cdr (setq l (cdr l))) (go lp)))
(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)))
(t (edit4e lc1 (car l))))
(setq y (editnth (car l) m))
(setq z (editnth (car l) n))
(editsmash y (car z) (cdr y))
(editsmash z tem (cdr z)))))
(cond ((null lc) (edloc x) (setq x nil)))
(cond ((null lc) (edloc (cdr x)) (setq x nil))
(setq z (cond (cp (copy (caar l))) (t (caar l))))
(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)))
(cond ((not cp) (editcoms '(1 delete)))
(toflg (editcoml '(bo 1) nil))))
(cond ((null lc) (setq unfind l1) l)
((null x) (setq unfind l1) l0)
(t (setq unfind l) l0))))))
(cond (lc1 (edloc lc1) (edup)))
(cond ((and (numberp lc1)
(difference (add1 lc2) lc1))
((and (eq flg 'to) (cdaar l))
(cond ((minusp (setq depth (eval depth))) (err nil)))
((lambda (l lcflg) (editcom place nil) l) l '_)))
(cond ((< n2 (+ n1 depth)) (err nil)))
(setq l (Cnth l (difference (add1 n2) n1 depth))))))
(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)))
(apply (car (setq def (cadr def)))
(cond ((null z) (setq unfind l) nil) (t z)))))
(cond ((null (cdr l)) (err nil)))
(cond ((tailp (car l) (cadr l)) (go lp))))))
(cond ((dtpr (car l)) (setq l (edit1f 1 l))))
(edit: ': nil (ncons (readlist (edite (explode (car l)) nil nil))))))
(mapc (function (lambda (x y) (editdsubst x y (car l)))) args (cdr ex))
(putprop (car ex) (cons 'lambda (cons args (car l))) 'expr)