[unix-history] / usr / lib / lisp / cmutpl.l

;;; cmu top level.
;;; Eventually this file will be able to be read in along with
;;; the standard franz top level and thus allow the user to select
;;; (possible via the .lisprc) the top level he wants.
;;;
(setq rcs-cmutpl-
   "$Header: /usr/lib/lisp/cmutpl.l,v 1.1 83/01/29 18:34:38 jkf Exp $")

(eval-when (compile eval)
   (or (get 'cmumacs 'version) (load 'cmumacs))
   (or (get 'cmufncs 'version) (load 'cmufncs)))

(declare (special history tlbuffer tlmacros historylength))

(dv historylength 25)

(def matchq
  (lambda (x y)
    (prog (xx yy)
          (return
           (cond
            ((and (atom x) (atom y))
             (cond ((matchq1 (setq xx (explode x)) (setq yy (explode y)))
                    (*** freelist xx)
                    (*** freelist yy)
                    t)
                   (t (*** freelist xx) (*** freelist yy)))))))))

(def matchq1
  (lambda (x y)
    (prog nil
     l1   (cond ((eq x y) (return t))
                ((or (equal y '(@)) (equal x '(@))) (return t))
                ((or (null x) (null y)) (return nil))
                ((eq (car x) (car y))
                 (setq x (cdr x))
                 (setq y (cdr y))
                 (go l1))
                (t (return nil))))))

(def showevents
  (lambda (evs)
    (for-each ev
              evs
              (terpri)
              (princ (car ev))
              (princ '".")
              (tlprint (cadr ev))
              (cond ((cddr ev) (terpri) (tlprint (caddr ev)))))))

(def tleval
  (lambda (exp)
    (prog (val)
          (setq val (eval exp))
          (rplacd (cdar history) (ncons val))
          (return val))))

(def tlgetevent
  (lambda (x)
    (cond ((null x) (car history))
          ((and (fixp x) (plusp x)) (assoc x history))
          ((and (fixp x) (minusp x)) (car (Cnth history (minus x)))))))

(dv tlmacros
    ((ed lambda
         (x)
         (prog (exp)
               (cond ((setq exp (copy (cadr (tlgetevent (cadr x)))))
                      (edite exp nil nil)
                      (return (ncons exp)))
                     (t (princ '"No such event")))))
     (redo lambda
           (x)
           (prog (exp)
                 (cond ((setq exp (tlgetevent (cadr x)))
                        (return (ncons (cadr exp))))
                       (t (princ '"No such event")))))
     (?? lambda
         (x)
         (prog (e1 e2 rest)
               (cond ((null (cdr x)) (showevents (reverse history)))
                     ((null (setq e1 (tlgetevent (cadr x))))
                      (princ '"No such event as ")
                      (princ (cadr x)))
                     ((null (cddr x)) (showevents (ncons e1)))
                     ((null (setq e2 (tlgetevent (caddr x))))
                      (princ '"No such event as ")
                      (princ (caddr x)))
                     (t (setq e1 (memq e1 history))
                        (cond ((setq rest (memq e2 e1))
                               (showevents
                                (cons e2 (reverse (ldiff e1 rest)))))
                              (t
                               (showevents
                                (cons (car e1)
                                      (reverse
                                       (ldiff (memq e2 history) e1))))))))))))

(def tlprint
  (lambda (x)
    (prinlev x 4)))

(def tlquote
  (lambda (x)
    (prog (ans)
     l    (cond ((null x) (return (reverse ans)))
                ((eq (car x) '!)
                 (setq ans (cons (cadr x) ans))
                 (setq x (cddr x)))
                (t (setq ans (cons (kwote (car x)) ans)) (setq x (cdr x))))
          (go l))))

(def tlread
  (lambda nil
    (prog (cmd tmp)
     top  (cond ((not (boundp 'history)) (setq history nil)))
          (cond
           ((null tlbuffer)
            (terpri)
            (princ (add1 (cond (history (caar history)) (t 0))))
            (princ '".")
            (cond
             ((null (setq tlbuffer (lineread)))
              (princ 'Bye)
              (terpri)
              (exit)))))
          (cond ((not (atom (setq cmd (car tlbuffer))))
                 (setq tlbuffer (cdr tlbuffer))
                 (go record))
                ((setq cmd (assoc cmd tlmacros))
                 (setq tmp tlbuffer)
                 (setq tlbuffer nil)
                 (setq cmd (apply (cdr cmd) (ncons tmp)))
                 (cond ((atom cmd) (go top))
                       (t (setq cmd (car cmd)) (go record))))
                ((and (null (cdr tlbuffer))
                      (or (numberp (car tlbuffer))
                          (stringp (car tlbuffer))
                          (hunkp (car tlbuffer))
                          (boundp (car tlbuffer))))
                 (setq cmd (car tlbuffer))
                 (setq tlbuffer nil)
                 (go record))
                ((or (and (dtpr (getd (car tlbuffer)))
                          (memq (car (getd (car tlbuffer)))
                                '(lexpr lambda)))
                     (and (bcdp (getd (car tlbuffer)))
                          (eq (getdisc (getd (car tlbuffer)))
                              'lambda)))
                 (setq cmd (cons (car tlbuffer) (tlquote (cdr tlbuffer))))
                 (setq tlbuffer nil)
                 (go record)))
          (setq cmd tlbuffer)
          (setq tlbuffer nil)
     record
          (setq history
                (cons (list (add1 (cond (history (caar history)) (t 0))) cmd)
                      history))
          (cond
           ((dtpr (cdr (setq tmp (Cnth history historylength))))
            (rplacd tmp nil)))
          (return cmd)))]

(def cmu-top-level
  (lambda nil
    (prog (tlbuffer)
     l    (tlprint (tleval (tlread)))
          (go l)))]

; LWE 1/11/81 The following might make this sucker work after resets:

(setq user-top-level 'cmu-top-level)
(putd 'user-top-level (getd 'cmu-top-level))
(setq top-level 'cmu-top-level)
(putd 'top-level (getd 'cmu-top-level))

(def transprint
  (lambda (prt)
    (prog nil
     l    (cond ((memq (tyipeek prt) '(27 -1)) (return nil))
                (t (tyo (tyi prt)) (go l))))))

(def valueof
  (lambda (x)
    (caddr (tlgetevent x))))

(def zap
  (lambda (prt)
    (prog nil
     l    (cond ((memq (tyi prt) '(10 -1)) (return nil)) (t (go l))))))
(dv dc-switch dc-define)
Commit	Line	Data
5ffa1c4c C	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)