[unix-history] / usr / src / cmd / lisp / lib / editor.l

(setq SCCS-editor "@(#)editor.l	1.1	10/2/80")

; editor from bbn-lisp c. 1968 
; (transcribed by R. Fateman for UNIX LISP, Oct., 1977)
; (modified and enhanced by P. Pifer, May, 1978)
; (corrected again by R. Fateman for VAX Unix Lisp, Dec., 1978)
; (cleaned up, commented and compiled by J. Foderaro, Aug., 1979)
; ( ... fixed bug in ^ command)
;
(declare (special edok em pf pl l))


 (setq printflag t)
; print on by default

 (setq printlevel 3)

 (setq maxlevel 100)

 (setq findflag nil)

(setq supereditflg t)(setq printflag t)(setq edrptcnt nil)


;--- remedit - removes all traces of the editor from the oblist.
;	       Note that if the editor is compiled, the code space
;	       will not be reclaimed
;
(def remedit
  (lambda nil
	  (prog nil
		(mapc (function (lambda (x) (set x nil)))
		      '(editmacros findflag supereditflg edrptcnt
			printflag printlevel maxlevel))
		(mapc (function (lambda (x) (putd x nil)))
		      '(editf editv tconc eprint eprint1 printlevel dsubst 
			editcoms edit1f edit2f edit2af edit4e 
			editqf edit4e edit4f edit4f1 editnth bpnt 
			bpnt0 subpair subpr ri ro li lo bi bo 
			ldiff nthcdr attach edite editcom editdefault
			remedit))
		(return 'gone))))

;--- subst - a - newval
;	   - b : oldvall
;	   - c : string
;	substitute a for b in c
;
(def subst
      (lambda (a b c)
	      (cond ((equal b c) a)
		    ((atom c) c)
		    (t (cons (subst a b (car c)) (subst a b (cdr c)))))))

(def tconc
      (lambda (x p)
	      (cond ((null (car p))
		     (rplacd p (car (rplaca p (list x)))))
		    (t (rplacd p (cdr (rplacd (cdr p) (list x))))))))

;--- printlevel - x : new value
;	set the printlevel to x and return the old value
;	[change this to prog1 ]
;
(def printlevel
  (lambda (x)
	  (prog (a)
		(setq a printlevel)
		(setq printlevel x)
		(return a))))

;--- editf - funcname : name of function to edit
;	   - [cmds]   : commands to apply right away
;	This is the starting point in the editor.  You specify the
;	file you wish to edit and perhaps some initial commands to 
;	the editor. If the function is not machine coded you 
;	enter the editor.
;
(def editf
  (nlambda (x)
	   (prog (a c)
		 (setq a (getd (car x)))
		 (cond ((or (null a) (bcdp a))
			(return '(not editable))))
		 (putd (car x) (car (edite a (cdr x) nil)))
		 (return (car x)))))

'(def dsubst
  (lambda (x y z)
	  (prog nil
		(cond ((null z) (return z))
		      ((equal y (car z)) (rplaca z x) (go l)))
		(cond ((null (atom (car z))) (dsubst x y (car z))))
	   l    (dsubst x y (cdr z))
		(return z))))

;--- dsubst - x : oldval
;	    - y : newval
;	    - z : form
;	directly substitutes all occurances of x in form z with y.
;	It uses rplaca and does not copy the structure.
;
(def dsubst
  (lambda (x y z)
	  (cond ((dptr z) 
		 (cond ((equal y (car z))
			(rplaca (car z) x))
		       (t (dsubst x y (car z)))))
		(t z))
	  (dsubst x y (cdr z))
	  z))


(def editcoms (lambda (c) (mapc (function editcom) c)))

(def edit1f
  (lambda (c l)
	  (cond ((equal c 0)
		 (cond ((null (cdr l)) (err nil))
		       (t (cdr l))))
		((greaterp c 0)
		 (cond ((greaterp c (length (car l))) (err nil))
		       (t (cons (car (nthcdr (sub1 c) (car l) )) l))))
		((greaterp (times c -1) (length (car l)))
		 (err nil))
		(t (cons (car (nthcdr (plus (length (car l)) c) (car l) ))
			 l)))))

(def edit2f
  (lambda (c)
	  (cond ((greaterp (car c) 0)
		 (cond ((greaterp (car c) (length (car l)))
			(err nil))
		       (t (rplaca l (edit2af (sub1 (car c))
					     (car l)
					     (cdr c)
					     nil)))))
		((or (equal (car c) 0)
		     (null (cdr c))
		     (greaterp (times -1 (car c)) (length (car l))))
		 (err nil))
		(t (rplaca l (edit2af (sub1 (times -1 (car c)))
				      (car l)
				      (cdr c)
				      t))))))

 (def edit2af
      (lambda (n x r d)
	      (prog nil
		    (cond ((null (equal n 0))
			   (rplacd (nthcdr  (sub1 n) x)
				   (nconc r
					  (cond (d (nthcdr  n x))
						(t (nthcdr (add1 n) x ))))))
			  (d (attach (car r) x)
			     (rplacd x (nconc (cdr r) (cdr x))))
			  (r (rplaca x (car r))
			     (rplacd x (nconc (cdr r) (cdr x))))
			  (t (print (list 'aha x)) 
			     (rplaca x (cadr x)) 
			     (rplacd x (cddr x))))
		    (return x))))

(def edit4e
      (lambda (x y)
	      (cond ((equal x y) t)
		    ((atom x) (eq x '&))
		    ((atom y) nil)
		    ((edit4e (car x) (car y))
		     (or (eq (cadr x) '-)
			 (edit4e (cdr x) (cdr y)))))))

(def editqf
  (lambda (s)
	  (prog (q1)
		(return (cond ((setq q1 (member s (cdar l)))
			       (setq l (cons q1 l)))
			      (t (edit4f s 'n)
				 (cond ((not (atom s))
					(setq l (cons (caar l) l))))))))))

(def edit4f
  (lambda (s n)
	  (prog (ff ll x)
		(setq ll (cond ((eq n 'n) (cons (caar l) l))
			       (t l)))
		(setq x (car ll))
		(setq ff (cons nil nil))
		(cond ((and n (not (numberp n))) (setq n 1)))
	lp      (cond ((edit4f1 s x maxlevel)
		       (setq l (nconc (car ff) ll))
		       (return (car l)))
		      ((null n) (err nil)))
	lp1     (setq x (car ll))
		(cond ((null (setq ll (cdr ll))) (err nil))
		      ((and (setq x (member x (car ll)))
			    (null (atom (setq x (cdr x)))))
		       (go lp)))
		(go lp1))))

(def edit4f1
  (lambda (s a lvl)
	  (prog nil
		(cond ((null (greaterp lvl 0)) (return nil)))
	lp      (cond ((atom a) (return nil))
		      ((and (edit4e s (car a))
			    (or (null n)
				(equal 0 (setq n (sub1 n)))))
		       (return (tconc a ff)))
		      ((and s
			    (equal s (cdr a))
			    (or (null n)
				(equal 0 (setq n (sub1 n)))))
		       (return (tconc a ff)))
		      ((and n
			    (edit4f1 s (car a) (sub1 lvl))
			    (equal 0 n))
		       (return (tconc (car a) ff))))
		(setq a (cdr a))
		(go lp))))

(def editnth
  (lambda (x n)
	  (cond ((null (setq n (cond ((or (null (lessp n 0))
					  (greaterp (setq n
							  (plus (length x)
								n
								1))
						    0))
				      (nthcdr  (sub1 n) x)))))
		 (err nil))
		(t n))))

(def bpnt
  (lambda (x)
	  (prog (y n)
		(cond ((equal 0 (car x)) (setq y (car l)))
		      (t (setq y (car (editnth (car l) (car x))))))
		(cond ((null (cdr x)) (setq n 3))
		      ((null (numberp (cadr x))) (go b1))
		      ((lessp (cadr x) 0)
		       (setq n (plus (cadr x) 2)))
		      (t (setq n (cadr x))))
		(return (bpnt0 y 1 n))
	b1      (err nil))))

(def bpnt0
  (lambda (l n d)
	  (prog (oldl)
		(setq oldl (printlevel (difference d n)))
		(cond ((atom (errset (eprint l) t))
		       (terpri)
		       (terpri)))
		(printlevel oldl)
		(return nil))))


(def ro
  (lambda (n x)
	  (prog (a)
		(setq a (editnth x n))
		(cond ((or (null a) (atom (car a))) (err nil)))
		(rplacd (last (car a)) (cdr a))
		(rplacd a nil))))

(def ri
  (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)))
		(rplacd a (nconc (cdr b) (cdr a)))
		(rplacd b nil))))

(def li
  (lambda (n x)
	  (prog (a)
		(setq a (editnth x n))
		(cond ((null a) (err nil)))
		(rplaca a (cons (car a) (cdr a)))
		(rplacd a nil))))

(def lo
  (lambda (n x)
	  (prog (a)
		(setq a (editnth x n))
		(cond ((or (null a) (atom (car a))) (err nil)))
		(rplacd a (cdar a))
		(rplaca a (caar a)))))

(def bi
  (lambda (m n x)
	  (prog (a b)
		(setq b (cdr (setq a (editnth x n))))
		(setq x (editnth x m))
		(cond ((and a (null (greaterp (length a) (length x))))
		       (rplacd a nil)
		       (rplaca x (cons (car x) (cdr x)))
		       (rplacd x b))
		      (t (err nil))))))

(def bo
  (lambda (n x)
	  (prog nil
		(setq x (editnth x n))
		(cond ((atom (car x)) (err nil)))
		(rplacd x (nconc (cdar x) (cdr x)))
		(return (rplaca x (caar x))))))

(def subpair
  (lambda (x y z fl)
	  (cond (fl (subpr x y (copy z)))
		((subpr x y z)))))

 (def subpr
      (lambda (x y z)
	      (prog (c d)
		    (setq c x)
		    (setq d y)
	    loop    (cond ((or (null c) (null d)) (return z))
			  (t (dsubst (car d) (car c) z)
			     (setq c (cdr c))
			     (setq d (cdr d))
			     (go loop))))))

(def ldiff
  (lambda (x y)
	  (prog (a b)
		(setq a x)
		(setq b nil)
	loop    (cond ((equal a y) (return (reverse b)))
		      ((null a) (return (err nil)))
		      (t (setq b (cons (car a) b))
			 (setq a (cdr a))
			 (go loop))))))

(def editv
  (nlambda (editvx)
	   (prog nil
		 (set (car editvx)
		      (car (edite (eval (car editvx))
				  (cdr editvx)
				  nil)))
		 (return (car editvx)))))

(def nthcdr
  (lambda (n x)
	  (cond ((equal n 0) x)
		((lessp n 0) (cons nil x))
		(t (nthcdr  (sub1 n)(cdr x))))))

(def attach
  (lambda (x y)
	  (prog (a)
		(setq a (cons (car y) (cdr y)))
		(rplaca y x)
		(rplacd y a)
		(return y))))

 (def eprint (lambda (x) (print (eprint1 x printlevel))))

(def edite
  (lambda (x ops l)
	  (prog (c m em edok copied pf pl)
		(cond ((null l) (setq l (list x))))
		(setq em editmacros)
		(setq pf printflag)
		(setq pl 3)
		(cond (ops (cond ((dtpr (errset (mapc 
					     (function 
					        (lambda (x)
							(editcom (setq c x))))
					     ops)
					  t))
				  (return (car (last l))))
				 (t (go b)))))
		(print 'edit)
		(cond (pf (terpri) (editcom 'p)))
		(setq pf printflag)
	ct      (setq findflag nil)
	a       (cond (edok (return (cdr edok))))
		(terpri)
		(patom '*)
		(drain)
		(cond ((atom (errset (setq c (read)) t)) (go ct)))
		(cond ((dtpr (errset (editcom c) t))
		       (cond (pf (editcom 'p)))
		       (setq pf printflag)
		       (go a)))
	b       (terpri)
		(print c)
		(patom '?)
		(terpri)
		(go ct))))

(def editdefault
      (lambda (x) (editcom (list 'f x 't))))

(def editcom
  (lambda (c)
	  (prog (cc c2 c3 cl)
	a       (cond (findflag (setq findflag nil) (editqf c))
		      ((numberp c) (setq l (edit1f c l)))
		      ((atom c)
		       (cond ((eq c 'ok)
			      (setq ersetflg t)
			      (setq edok (cons t (last l)))
			      (return (setq pf nil)))
			     ((eq c 'e)
			      (setq ersetflg t)
			      (print (eval (read)))
			      (terpri))
			     ((eq c 'p)
			      (setq pf nil)
			      (bpnt0 (car l) 1 pl))
			     ((eq c 'pp)
			      (setq pf nil)
			      (terpri)
			      (errset ($prpr (car l)) t)
			      (terpri))
			     ((eq c 'mark)
			      (setq m (cons l m)))
			     ((eq c '^)
			      (setq l (list (last l))))
			     ((eq c 'copy) (setq copied (copy l)))
			     ((eq c 'restore) (setq l copied))
			     ((eq c '<)
			      (cond (m (setq l (car m)))
				    (t (err '"no marks"))))
			     ((eq c '<<)
			      (cond (m (setq l (car m))
				       (setq m (cdr m)))
				    (t (err '"no marks"))))
			     ((eq c 'poff)
			      (setq pf nil)
			      (setq printflag nil))
			     ((eq c 'pon)
			      (setq pf t)
			      (setq printflag t))
			     (t (cond ((and (setq cc
						  (cond ((null
							  (setq cc 
								(assoc c em)))
							 nil)
							((cdr cc))))
					    (null (car cc)))
				       (editcoms (copy cc)))
				      (t (return (editdefault c)))))))
		      ((numberp (setq cc (car c))) (edit2f c))
		      (t (setq c2 (cadr c))
			 (setq c3
			       (cond ((null (cddr c)) nil)
				     ((car (cddr c)))))
			 (setq cl (car l))
			 (cond ((eq cc 's)
				(set c2
				     (car (cond ((null (setq c c3)) l)
						((equal c 0) l)
						(t (editnth cl c))))))
			       ((eq cc 'r)
				(dsubst c3 c2 cl))
			       ((eq cc 'e)
				(setq cc (eval c2))
				(cond ((null (cddr c))
				       (print cc)
				       (terpri)))
				(return cc))
			       ((eq cc 'i)
				(setq c
				      (cons (cond ((atom c2) c2)
						  (t (eval c2)))
					    (mapcar (function eval)
						    (cddr c))))
				(go a))
			       ((eq cc 'n)
				(nconc cl (cdr c)))
			       ((eq cc 'p)
				(bpnt (cdr c))
				(setq pf nil))
			       ((eq cc 'f)
				(edit4f c2 c3))
			       ((eq cc 'nth)
				(setq l (cons (editnth cl c2) l)))
			       ((member cc
					 '(ri ro li lo bi bo))
				(apply1 cc (append (cdr c) (list cl))))
			       ((member cc '(m d))
				(setq cc (cond ((atom (setq cc c2))
						(cons cc
						      (cons nil
							    (cddr c))))
					       (t (cons (car cc) (cddr c)))))
				(setq em (cons cc em))
				(cond ((eq (car c) 'm) 
				       (setq editmacros
					     (cons cc editmacros)))))
			       ((eq cc 'pl)
				(cond ((lessp c2 1) (err nil))
				      (t (setq pl (add 1 c2)))))
			       (t (cond ((or (null
					      (setq cc
						    (cond ((null
							    (setq cc
								  (assoc cc em)))
							   nil)
							  (t (cdr cc)))))
					     (null (cond ((null cc) nil)
							 (t (car cc)))))
					 (return (editdefault c)))
					((atom (car cc))
					 (editcoms
					  (subst (cond ((null c) nil)
						       ((cdr c)))
						 (car cc)
						 (cdr cc))))
					(t (editcoms
					    (subpair (car cc)
						     (cdr c)
						     (cdr cc)
						     t))))))))
		(return (car l)))))

(def eprint1
  (lambda (x lev)
	  (cond ((atom x) x)
		((equal 0 lev) '&)
		((and (atom (cdr x)) (cdr x)) x)
		(t (mapcar (function (lambda (y) (eprint1 y (sub1 lev))))
			   x)))))

(def assoc
  (lambda (e l)
	  (cond ((null l) nil)
		((equal e (caar l)) (car l))
		(t (assoc e (cdr l))))))

 (def apply1
      (lambda (f l)
	      (eval (cons f (mapcar '(lambda (z) (list 'quote z))
				    l)))))


(def editp
  (nlambda (x)
	   (prog (a b)
		 (setq a (car x))
		 (edite (caar x))
		 (return a))))

(def makefile
  (nlambda (x)
	   (prog (poport n f ff l df)
		 (setq l (cons nil (cadr x)))
		 (setq ff (eval (car x)))
		 (setq poport
		       (outfile (setq n (concatp 'mkfl))))
	l1       (cond ((null (setq l (cdr l))) (go e1)))
		 (setq f (car l))
		 (cond ((null f) (go l1))
		       ((null (setq df (getd f))) (go l1))
		       (t (setq df (list 'def f df))
			  ($prpr df)
			  (terpri)
			  (go l1)))
	e1       (close poport)
		 (null (eval (cons 'exec (cons '/bin/mv (cons n (cons ff nil)))))))))

(def appfile
  (nlambda (x)
	   (prog (i poport n f ff l df)
		 (setq l (cons nil (cadr x)))
		 (setq ff (eval (car x)))
		 (setq i (infile ff))
		 (setq poport
		       (outfile (setq n (concatp 'apfl))))
	l1       (cond ((eq (setq f (read i poport)) 'eof)
			(go l2))
		       (t ($prpr f) (terpri)))
		 (go l1)
	l2       (cond ((null (setq l (cdr l))) (go e1)))
		 (setq f (car l))
		 (cond ((null f) (go l2))
		       ((null (setq df (getd f))) (go l2))
		       (t (setq df (list 'def f df))
			  ($prpr df)
			  (terpri)
			  (go l2)))
	e1       (close poport)
		 (null (eval (cons 'exec (cons '/bin/mv (cons n (cons ff nil)))))))))

(def exec
  (nlambda ($list)
	   (prog ($handy)
		 (setq $handy '"")
	 loop    (cond ((null $list)
			(return (eval (list 'process $handy))))
		       (t (setq $handy
				(concat (concat $handy (car $list))
					'" "))
			  (setq $list (cdr $list))
			  (go loop))))))

(setq editmacros nil)
Commit	Line	Data
31cef89c BJ	1	(setq SCCS-editor "@(#)editor.l 1.1 10/2/80")
31cef89c BJ	2
bdd42f63 JF	3	; editor from bbn-lisp c. 1968
	4	; (transcribed by R. Fateman for UNIX LISP, Oct., 1977)
	5	; (modified and enhanced by P. Pifer, May, 1978)
	6	; (corrected again by R. Fateman for VAX Unix Lisp, Dec., 1978)
	7	; (cleaned up, commented and compiled by J. Foderaro, Aug., 1979)
	8	; ( ... fixed bug in ^ command)
	9	;
	10	(declare (special edok em pf pl l))
	11
	12
	13	(setq printflag t)
	14	; print on by default
	15
	16	(setq printlevel 3)
	17
	18	(setq maxlevel 100)
	19
	20	(setq findflag nil)
	21
	22	(setq supereditflg t)(setq printflag t)(setq edrptcnt nil)
	23
	24
	25	;--- remedit - removes all traces of the editor from the oblist.
	26	; Note that if the editor is compiled, the code space
	27	; will not be reclaimed
	28	;
	29	(def remedit
	30	(lambda nil
	31	(prog nil
	32	(mapc (function (lambda (x) (set x nil)))
	33	'(editmacros findflag supereditflg edrptcnt
	34	printflag printlevel maxlevel))
	35	(mapc (function (lambda (x) (putd x nil)))
	36	'(editf editv tconc eprint eprint1 printlevel dsubst
	37	editcoms edit1f edit2f edit2af edit4e
	38	editqf edit4e edit4f edit4f1 editnth bpnt
	39	bpnt0 subpair subpr ri ro li lo bi bo
	40	ldiff nthcdr attach edite editcom editdefault
	41	remedit))
	42	(return 'gone))))
	43
	44	;--- subst - a - newval
	45	; - b : oldvall
	46	; - c : string
	47	; substitute a for b in c
	48	;
	49	(def subst
	50	(lambda (a b c)
	51	(cond ((equal b c) a)
	52	((atom c) c)
	53	(t (cons (subst a b (car c)) (subst a b (cdr c)))))))
	54
	55	(def tconc
	56	(lambda (x p)
	57	(cond ((null (car p))
	58	(rplacd p (car (rplaca p (list x)))))
	59	(t (rplacd p (cdr (rplacd (cdr p) (list x))))))))
	60
	61	;--- printlevel - x : new value
	62	; set the printlevel to x and return the old value
	63	; [change this to prog1 ]
	64	;
	65	(def printlevel
	66	(lambda (x)
67	(prog (a)
68	(setq a printlevel)
69	(setq printlevel x)
70	(return a))))
71
72	;--- editf - funcname : name of function to edit
73	; - [cmds] : commands to apply right away
74	; This is the starting point in the editor. You specify the
75	; file you wish to edit and perhaps some initial commands to
76	; the editor. If the function is not machine coded you
77	; enter the editor.
78	;
79	(def editf
80	(nlambda (x)
81	(prog (a c)
82	(setq a (getd (car x)))
83	(cond ((or (null a) (bcdp a))
84	(return '(not editable))))
85	(putd (car x) (car (edite a (cdr x) nil)))
86	(return (car x)))))
87
88	'(def dsubst
89	(lambda (x y z)
90	(prog nil
91	(cond ((null z) (return z))
92	((equal y (car z)) (rplaca z x) (go l)))
93	(cond ((null (atom (car z))) (dsubst x y (car z))))
94	l (dsubst x y (cdr z))
95	(return z))))
96
97	;--- dsubst - x : oldval
98	; - y : newval
99	; - z : form
100	; directly substitutes all occurances of x in form z with y.
101	; It uses rplaca and does not copy the structure.
102	;
103	(def dsubst
104	(lambda (x y z)
105	(cond ((dptr z)
106	(cond ((equal y (car z))
107	(rplaca (car z) x))
108	(t (dsubst x y (car z)))))
109	(t z))
110	(dsubst x y (cdr z))
111	z))
112
113
114	(def editcoms (lambda (c) (mapc (function editcom) c)))
115
116	(def edit1f
117	(lambda (c l)
118	(cond ((equal c 0)
119	(cond ((null (cdr l)) (err nil))
120	(t (cdr l))))
121	((greaterp c 0)
122	(cond ((greaterp c (length (car l))) (err nil))
123	(t (cons (car (nthcdr (sub1 c) (car l) )) l))))
124	((greaterp (times c -1) (length (car l)))
125	(err nil))
126	(t (cons (car (nthcdr (plus (length (car l)) c) (car l) ))
127	l)))))
128
129	(def edit2f
130	(lambda (c)
131	(cond ((greaterp (car c) 0)
132	(cond ((greaterp (car c) (length (car l)))
133	(err nil))
134	(t (rplaca l (edit2af (sub1 (car c))
135	(car l)
136	(cdr c)
137	nil)))))
138	((or (equal (car c) 0)
139	(null (cdr c))
140	(greaterp (times -1 (car c)) (length (car l))))
141	(err nil))
142	(t (rplaca l (edit2af (sub1 (times -1 (car c)))
143	(car l)
144	(cdr c)
145	t))))))
146
147	(def edit2af
148	(lambda (n x r d)
149	(prog nil
150	(cond ((null (equal n 0))
151	(rplacd (nthcdr (sub1 n) x)
152	(nconc r
153	(cond (d (nthcdr n x))
154	(t (nthcdr (add1 n) x ))))))
155	(d (attach (car r) x)
156	(rplacd x (nconc (cdr r) (cdr x))))
157	(r (rplaca x (car r))
158	(rplacd x (nconc (cdr r) (cdr x))))
159	(t (print (list 'aha x))
160	(rplaca x (cadr x))
161	(rplacd x (cddr x))))
162	(return x))))
163
164	(def edit4e
165	(lambda (x y)
166	(cond ((equal x y) t)
167	((atom x) (eq x '&))
168	((atom y) nil)
169	((edit4e (car x) (car y))
170	(or (eq (cadr x) '-)
171	(edit4e (cdr x) (cdr y)))))))
172
173	(def editqf
174	(lambda (s)
175	(prog (q1)
176	(return (cond ((setq q1 (member s (cdar l)))
177	(setq l (cons q1 l)))
178	(t (edit4f s 'n)
179	(cond ((not (atom s))
180	(setq l (cons (caar l) l))))))))))
181
182	(def edit4f
183	(lambda (s n)
184	(prog (ff ll x)
185	(setq ll (cond ((eq n 'n) (cons (caar l) l))
186	(t l)))
187	(setq x (car ll))
188	(setq ff (cons nil nil))
189	(cond ((and n (not (numberp n))) (setq n 1)))
190	lp (cond ((edit4f1 s x maxlevel)
191	(setq l (nconc (car ff) ll))
192	(return (car l)))
193	((null n) (err nil)))
194	lp1 (setq x (car ll))
195	(cond ((null (setq ll (cdr ll))) (err nil))
196	((and (setq x (member x (car ll)))
197	(null (atom (setq x (cdr x)))))
198	(go lp)))
199	(go lp1))))
200
201	(def edit4f1
202	(lambda (s a lvl)
203	(prog nil
204	(cond ((null (greaterp lvl 0)) (return nil)))
205	lp (cond ((atom a) (return nil))
206	((and (edit4e s (car a))
207	(or (null n)
208	(equal 0 (setq n (sub1 n)))))
209	(return (tconc a ff)))
210	((and s
211	(equal s (cdr a))
212	(or (null n)
213	(equal 0 (setq n (sub1 n)))))
214	(return (tconc a ff)))
215	((and n
216	(edit4f1 s (car a) (sub1 lvl))
217	(equal 0 n))
218	(return (tconc (car a) ff))))
219	(setq a (cdr a))
220	(go lp))))
221
222	(def editnth
223	(lambda (x n)
224	(cond ((null (setq n (cond ((or (null (lessp n 0))
225	(greaterp (setq n
226	(plus (length x)
227	n
228	1))
229	0))
230	(nthcdr (sub1 n) x)))))
231	(err nil))
232	(t n))))
233
234	(def bpnt
235	(lambda (x)
236	(prog (y n)
237	(cond ((equal 0 (car x)) (setq y (car l)))
238	(t (setq y (car (editnth (car l) (car x))))))
239	(cond ((null (cdr x)) (setq n 3))
240	((null (numberp (cadr x))) (go b1))
241	((lessp (cadr x) 0)
242	(setq n (plus (cadr x) 2)))
243	(t (setq n (cadr x))))
244	(return (bpnt0 y 1 n))
245	b1 (err nil))))
246
247	(def bpnt0
248	(lambda (l n d)
249	(prog (oldl)
250	(setq oldl (printlevel (difference d n)))
251	(cond ((atom (errset (eprint l) t))
252	(terpri)
253	(terpri)))
254	(printlevel oldl)
255	(return nil))))
256
257
258	(def ro
259	(lambda (n x)
260	(prog (a)
261	(setq a (editnth x n))
262	(cond ((or (null a) (atom (car a))) (err nil)))
263	(rplacd (last (car a)) (cdr a))
264	(rplacd a nil))))
265
266	(def ri
267	(lambda (m n x)
268	(prog (a b)
269	(setq a (editnth x m))
270	(setq b (editnth (car a) n))
271	(cond ((or (null a) (null b)) (err nil)))
272	(rplacd a (nconc (cdr b) (cdr a)))
273	(rplacd b nil))))
274
275	(def li
276	(lambda (n x)
277	(prog (a)
278	(setq a (editnth x n))
279	(cond ((null a) (err nil)))
280	(rplaca a (cons (car a) (cdr a)))
281	(rplacd a nil))))
282
283	(def lo
284	(lambda (n x)
285	(prog (a)
286	(setq a (editnth x n))
287	(cond ((or (null a) (atom (car a))) (err nil)))
288	(rplacd a (cdar a))
289	(rplaca a (caar a)))))
290
291	(def bi
292	(lambda (m n x)
293	(prog (a b)
294	(setq b (cdr (setq a (editnth x n))))
295	(setq x (editnth x m))
296	(cond ((and a (null (greaterp (length a) (length x))))
297	(rplacd a nil)
298	(rplaca x (cons (car x) (cdr x)))
299	(rplacd x b))
300	(t (err nil))))))
301
302	(def bo
303	(lambda (n x)
304	(prog nil
305	(setq x (editnth x n))
306	(cond ((atom (car x)) (err nil)))
307	(rplacd x (nconc (cdar x) (cdr x)))
308	(return (rplaca x (caar x))))))
309
310	(def subpair
311	(lambda (x y z fl)
312	(cond (fl (subpr x y (copy z)))
313	((subpr x y z)))))
314
315	(def subpr
316	(lambda (x y z)
317	(prog (c d)
318	(setq c x)
319	(setq d y)
320	loop (cond ((or (null c) (null d)) (return z))
321	(t (dsubst (car d) (car c) z)
322	(setq c (cdr c))
323	(setq d (cdr d))
324	(go loop))))))
325
326	(def ldiff
327	(lambda (x y)
328	(prog (a b)
329	(setq a x)
330	(setq b nil)
331	loop (cond ((equal a y) (return (reverse b)))
332	((null a) (return (err nil)))
333	(t (setq b (cons (car a) b))
334	(setq a (cdr a))
335	(go loop))))))
336
337	(def editv
338	(nlambda (editvx)
339	(prog nil
340	(set (car editvx)
341	(car (edite (eval (car editvx))
342	(cdr editvx)
343	nil)))
344	(return (car editvx)))))
345
346	(def nthcdr
347	(lambda (n x)
348	(cond ((equal n 0) x)
349	((lessp n 0) (cons nil x))
350	(t (nthcdr (sub1 n)(cdr x))))))
351
352	(def attach
353	(lambda (x y)
354	(prog (a)
355	(setq a (cons (car y) (cdr y)))
356	(rplaca y x)
357	(rplacd y a)
358	(return y))))
359
360	(def eprint (lambda (x) (print (eprint1 x printlevel))))
361
362	(def edite
363	(lambda (x ops l)
364	(prog (c m em edok copied pf pl)
365	(cond ((null l) (setq l (list x))))
366	(setq em editmacros)
367	(setq pf printflag)
368	(setq pl 3)
369	(cond (ops (cond ((dtpr (errset (mapc
370	(function
371	(lambda (x)
372	(editcom (setq c x))))
373	ops)
374	t))
375	(return (car (last l))))
376	(t (go b)))))
377	(print 'edit)
378	(cond (pf (terpri) (editcom 'p)))
379	(setq pf printflag)
380	ct (setq findflag nil)
381	a (cond (edok (return (cdr edok))))
382	(terpri)
383	(patom '*)
384	(drain)
385	(cond ((atom (errset (setq c (read)) t)) (go ct)))
386	(cond ((dtpr (errset (editcom c) t))
387	(cond (pf (editcom 'p)))
388	(setq pf printflag)
389	(go a)))
390	b (terpri)
391	(print c)
392	(patom '?)
393	(terpri)
394	(go ct))))
395
396	(def editdefault
397	(lambda (x) (editcom (list 'f x 't))))
398
399	(def editcom
400	(lambda (c)
401	(prog (cc c2 c3 cl)
402	a (cond (findflag (setq findflag nil) (editqf c))
403	((numberp c) (setq l (edit1f c l)))
404	((atom c)
405	(cond ((eq c 'ok)
406	(setq ersetflg t)
407	(setq edok (cons t (last l)))
408	(return (setq pf nil)))
409	((eq c 'e)
410	(setq ersetflg t)
411	(print (eval (read)))
412	(terpri))
413	((eq c 'p)
414	(setq pf nil)
415	(bpnt0 (car l) 1 pl))
416	((eq c 'pp)
417	(setq pf nil)
418	(terpri)
419	(errset ($prpr (car l)) t)
420	(terpri))
421	((eq c 'mark)
422	(setq m (cons l m)))
423	((eq c '^)
424	(setq l (list (last l))))
425	((eq c 'copy) (setq copied (copy l)))
426	((eq c 'restore) (setq l copied))
427	((eq c '<)
428	(cond (m (setq l (car m)))
429	(t (err '"no marks"))))
430	((eq c '<<)
431	(cond (m (setq l (car m))
432	(setq m (cdr m)))
433	(t (err '"no marks"))))
434	((eq c 'poff)
435	(setq pf nil)
436	(setq printflag nil))
437	((eq c 'pon)
438	(setq pf t)
439	(setq printflag t))
440	(t (cond ((and (setq cc
441	(cond ((null
442	(setq cc
443	(assoc c em)))
444	nil)
445	((cdr cc))))
446	(null (car cc)))
447	(editcoms (copy cc)))
448	(t (return (editdefault c)))))))
449	((numberp (setq cc (car c))) (edit2f c))
450	(t (setq c2 (cadr c))
451	(setq c3
452	(cond ((null (cddr c)) nil)
453	((car (cddr c)))))
454	(setq cl (car l))
455	(cond ((eq cc 's)
456	(set c2
457	(car (cond ((null (setq c c3)) l)
458	((equal c 0) l)
459	(t (editnth cl c))))))
460	((eq cc 'r)
461	(dsubst c3 c2 cl))
462	((eq cc 'e)
463	(setq cc (eval c2))
464	(cond ((null (cddr c))
465	(print cc)
466	(terpri)))
467	(return cc))
468	((eq cc 'i)
469	(setq c
470	(cons (cond ((atom c2) c2)
471	(t (eval c2)))
472	(mapcar (function eval)
473	(cddr c))))
474	(go a))
475	((eq cc 'n)
476	(nconc cl (cdr c)))
477	((eq cc 'p)
478	(bpnt (cdr c))
479	(setq pf nil))
480	((eq cc 'f)
481	(edit4f c2 c3))
482	((eq cc 'nth)
483	(setq l (cons (editnth cl c2) l)))
484	((member cc
485	'(ri ro li lo bi bo))
486	(apply1 cc (append (cdr c) (list cl))))
487	((member cc '(m d))
488	(setq cc (cond ((atom (setq cc c2))
489	(cons cc
490	(cons nil
491	(cddr c))))
492	(t (cons (car cc) (cddr c)))))
493	(setq em (cons cc em))
494	(cond ((eq (car c) 'm)
495	(setq editmacros
496	(cons cc editmacros)))))
497	((eq cc 'pl)
498	(cond ((lessp c2 1) (err nil))
499	(t (setq pl (add 1 c2)))))
500	(t (cond ((or (null
501	(setq cc
502	(cond ((null
503	(setq cc
504	(assoc cc em)))
505	nil)
506	(t (cdr cc)))))
507	(null (cond ((null cc) nil)
508	(t (car cc)))))
509	(return (editdefault c)))
510	((atom (car cc))
511	(editcoms
512	(subst (cond ((null c) nil)
513	((cdr c)))
514	(car cc)
515	(cdr cc))))
516	(t (editcoms
517	(subpair (car cc)
518	(cdr c)
519	(cdr cc)
520	t))))))))
521	(return (car l)))))
522
523	(def eprint1
524	(lambda (x lev)
525	(cond ((atom x) x)
526	((equal 0 lev) '&)
527	((and (atom (cdr x)) (cdr x)) x)
528	(t (mapcar (function (lambda (y) (eprint1 y (sub1 lev))))
529	x)))))
530
531	(def assoc
532	(lambda (e l)
533	(cond ((null l) nil)
534	((equal e (caar l)) (car l))
535	(t (assoc e (cdr l))))))
536
537	(def apply1
538	(lambda (f l)
539	(eval (cons f (mapcar '(lambda (z) (list 'quote z))
540	l)))))
541
542
543
544
545	(def editp
546	(nlambda (x)
547	(prog (a b)
548	(setq a (car x))
549	(edite (caar x))
550	(return a))))
551
552	(def makefile
553	(nlambda (x)
554	(prog (poport n f ff l df)
555	(setq l (cons nil (cadr x)))
556	(setq ff (eval (car x)))
557	(setq poport
558	(outfile (setq n (concatp 'mkfl))))
559	l1 (cond ((null (setq l (cdr l))) (go e1)))
560	(setq f (car l))
561	(cond ((null f) (go l1))
562	((null (setq df (getd f))) (go l1))
563	(t (setq df (list 'def f df))
564	($prpr df)
565	(terpri)
566	(go l1)))
567	e1 (close poport)
568	(null (eval (cons 'exec (cons '/bin/mv (cons n (cons ff nil)))))))))
569
570	(def appfile
571	(nlambda (x)
572	(prog (i poport n f ff l df)
573	(setq l (cons nil (cadr x)))
574	(setq ff (eval (car x)))
575	(setq i (infile ff))
576	(setq poport
577	(outfile (setq n (concatp 'apfl))))
578	l1 (cond ((eq (setq f (read i poport)) 'eof)
579	(go l2))
580	(t ($prpr f) (terpri)))
581	(go l1)
582	l2 (cond ((null (setq l (cdr l))) (go e1)))
583	(setq f (car l))
584	(cond ((null f) (go l2))
585	((null (setq df (getd f))) (go l2))
586	(t (setq df (list 'def f df))
587	($prpr df)
588	(terpri)
589	(go l2)))
590	e1 (close poport)
591	(null (eval (cons 'exec (cons '/bin/mv (cons n (cons ff nil)))))))))
592
593	(def exec
594	(nlambda ($list)
595	(prog ($handy)
596	(setq $handy '"")
597	loop (cond ((null $list)
598	(return (eval (list 'process $handy))))
599	(t (setq $handy
600	(concat (concat $handy (car $list))
601	'" "))
602	(setq $list (cdr $list))
603	(go loop))))))
604
605	(setq editmacros nil)