|
|
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.