![[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] / 42BSD / ucb / lisp / lisplib|
Return to cmutpl.l CVS log | Up to [CSRG BSD Unix] / 42BSD / 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.