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