![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to cmutpl.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib|
Return to cmutpl.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 ! root 1: ;;; cmu top level. ! 2: ;;; Eventually this file will be able to be read in along with ! 3: ;;; the standard franz top level and thus allow the user to select ! 4: ;;; (possible via the .lisprc) the top level he wants. ! 5: ;;; ! 6: (setq rcs-cmutpl- ! 7: "$Header: /usr/lib/lisp/cmutpl.l,v 1.1 83/01/29 18:34:38 jkf Exp $") ! 8: ! 9: (eval-when (compile eval) ! 10: (or (get 'cmumacs 'version) (load 'cmumacs)) ! 11: (or (get 'cmufncs 'version) (load 'cmufncs))) ! 12: ! 13: (declare (special history tlbuffer tlmacros historylength)) ! 14: ! 15: (dv historylength 25) ! 16: ! 17: (def matchq ! 18: (lambda (x y) ! 19: (prog (xx yy) ! 20: (return ! 21: (cond ! 22: ((and (atom x) (atom y)) ! 23: (cond ((matchq1 (setq xx (explode x)) (setq yy (explode y))) ! 24: (*** freelist xx) ! 25: (*** freelist yy) ! 26: t) ! 27: (t (*** freelist xx) (*** freelist yy))))))))) ! 28: ! 29: (def matchq1 ! 30: (lambda (x y) ! 31: (prog nil ! 32: l1 (cond ((eq x y) (return t)) ! 33: ((or (equal y '(@)) (equal x '(@))) (return t)) ! 34: ((or (null x) (null y)) (return nil)) ! 35: ((eq (car x) (car y)) ! 36: (setq x (cdr x)) ! 37: (setq y (cdr y)) ! 38: (go l1)) ! 39: (t (return nil)))))) ! 40: ! 41: (def showevents ! 42: (lambda (evs) ! 43: (for-each ev ! 44: evs ! 45: (terpri) ! 46: (princ (car ev)) ! 47: (princ '".") ! 48: (tlprint (cadr ev)) ! 49: (cond ((cddr ev) (terpri) (tlprint (caddr ev))))))) ! 50: ! 51: (def tleval ! 52: (lambda (exp) ! 53: (prog (val) ! 54: (setq val (eval exp)) ! 55: (rplacd (cdar history) (ncons val)) ! 56: (return val)))) ! 57: ! 58: (def tlgetevent ! 59: (lambda (x) ! 60: (cond ((null x) (car history)) ! 61: ((and (fixp x) (plusp x)) (assoc x history)) ! 62: ((and (fixp x) (minusp x)) (car (Cnth history (minus x))))))) ! 63: ! 64: (dv tlmacros ! 65: ((ed lambda ! 66: (x) ! 67: (prog (exp) ! 68: (cond ((setq exp (copy (cadr (tlgetevent (cadr x))))) ! 69: (edite exp nil nil) ! 70: (return (ncons exp))) ! 71: (t (princ '"No such event"))))) ! 72: (redo lambda ! 73: (x) ! 74: (prog (exp) ! 75: (cond ((setq exp (tlgetevent (cadr x))) ! 76: (return (ncons (cadr exp)))) ! 77: (t (princ '"No such event"))))) ! 78: (?? lambda ! 79: (x) ! 80: (prog (e1 e2 rest) ! 81: (cond ((null (cdr x)) (showevents (reverse history))) ! 82: ((null (setq e1 (tlgetevent (cadr x)))) ! 83: (princ '"No such event as ") ! 84: (princ (cadr x))) ! 85: ((null (cddr x)) (showevents (ncons e1))) ! 86: ((null (setq e2 (tlgetevent (caddr x)))) ! 87: (princ '"No such event as ") ! 88: (princ (caddr x))) ! 89: (t (setq e1 (memq e1 history)) ! 90: (cond ((setq rest (memq e2 e1)) ! 91: (showevents ! 92: (cons e2 (reverse (ldiff e1 rest))))) ! 93: (t ! 94: (showevents ! 95: (cons (car e1) ! 96: (reverse ! 97: (ldiff (memq e2 history) e1)))))))))))) ! 98: ! 99: (def tlprint ! 100: (lambda (x) ! 101: (prinlev x 4))) ! 102: ! 103: (def tlquote ! 104: (lambda (x) ! 105: (prog (ans) ! 106: l (cond ((null x) (return (reverse ans))) ! 107: ((eq (car x) '!) ! 108: (setq ans (cons (cadr x) ans)) ! 109: (setq x (cddr x))) ! 110: (t (setq ans (cons (kwote (car x)) ans)) (setq x (cdr x)))) ! 111: (go l)))) ! 112: ! 113: (def tlread ! 114: (lambda nil ! 115: (prog (cmd tmp) ! 116: top (cond ((not (boundp 'history)) (setq history nil))) ! 117: (cond ! 118: ((null tlbuffer) ! 119: (terpri) ! 120: (princ (add1 (cond (history (caar history)) (t 0)))) ! 121: (princ '".") ! 122: (cond ! 123: ((null (setq tlbuffer (lineread))) ! 124: (princ 'Bye) ! 125: (terpri) ! 126: (exit))))) ! 127: (cond ((not (atom (setq cmd (car tlbuffer)))) ! 128: (setq tlbuffer (cdr tlbuffer)) ! 129: (go record)) ! 130: ((setq cmd (assoc cmd tlmacros)) ! 131: (setq tmp tlbuffer) ! 132: (setq tlbuffer nil) ! 133: (setq cmd (apply (cdr cmd) (ncons tmp))) ! 134: (cond ((atom cmd) (go top)) ! 135: (t (setq cmd (car cmd)) (go record)))) ! 136: ((and (null (cdr tlbuffer)) ! 137: (or (numberp (car tlbuffer)) ! 138: (stringp (car tlbuffer)) ! 139: (hunkp (car tlbuffer)) ! 140: (boundp (car tlbuffer)))) ! 141: (setq cmd (car tlbuffer)) ! 142: (setq tlbuffer nil) ! 143: (go record)) ! 144: ((or (and (dtpr (getd (car tlbuffer))) ! 145: (memq (car (getd (car tlbuffer))) ! 146: '(lexpr lambda))) ! 147: (and (bcdp (getd (car tlbuffer))) ! 148: (eq (getdisc (getd (car tlbuffer))) ! 149: 'lambda))) ! 150: (setq cmd (cons (car tlbuffer) (tlquote (cdr tlbuffer)))) ! 151: (setq tlbuffer nil) ! 152: (go record))) ! 153: (setq cmd tlbuffer) ! 154: (setq tlbuffer nil) ! 155: record ! 156: (setq history ! 157: (cons (list (add1 (cond (history (caar history)) (t 0))) cmd) ! 158: history)) ! 159: (cond ! 160: ((dtpr (cdr (setq tmp (Cnth history historylength)))) ! 161: (rplacd tmp nil))) ! 162: (return cmd)))] ! 163: ! 164: (def cmu-top-level ! 165: (lambda nil ! 166: (prog (tlbuffer) ! 167: l (tlprint (tleval (tlread))) ! 168: (go l)))] ! 169: ! 170: ; LWE 1/11/81 The following might make this sucker work after resets: ! 171: ! 172: (setq user-top-level 'cmu-top-level) ! 173: (putd 'user-top-level (getd 'cmu-top-level)) ! 174: (setq top-level 'cmu-top-level) ! 175: (putd 'top-level (getd 'cmu-top-level)) ! 176: ! 177: (def transprint ! 178: (lambda (prt) ! 179: (prog nil ! 180: l (cond ((memq (tyipeek prt) '(27 -1)) (return nil)) ! 181: (t (tyo (tyi prt)) (go l)))))) ! 182: ! 183: (def valueof ! 184: (lambda (x) ! 185: (caddr (tlgetevent x)))) ! 186: ! 187: (def zap ! 188: (lambda (prt) ! 189: (prog nil ! 190: l (cond ((memq (tyi prt) '(10 -1)) (return nil)) (t (go l)))))) ! 191: (dv dc-switch dc-define)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.