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

(setq rcs-cmufncs-
   "$Header: /usr/lib/lisp/cmufncs.l,v 1.1 83/01/29 18:34:20 jkf Exp $")

(eval-when (compile eval) (load 'cmumacs))

(declare (special filelst %changes $%dotflg %prevfn% %%cfn part %%l
		  lastword %trcflg form fn))
(def tab (lexpr (n)
		(prog (nn prt) (setq nn (arg 1))
			       (cond ((> n 1)(setq prt (arg 2))))
			       (cond ((> (nwritn prt) nn) (terpri prt)))
			       (printblanks (- nn (nwritn prt)) prt))))


(dv $%dotflg nil)
(def %lineread
     (lambda 
      (chan)
      (prog (ans)
       loop (setq ans (cons (read chan 'EOF) ans))
	    (cond ((eq (car ans) 'EOF) (return (reverse (cdr ans)))))
       loop2(cond ((eq 10 (tyipeek chan)) (return (reverse ans)))
                  ((memq (tyipeek chan) '(41 93))
                   (tyi chan)
                   (go loop2))
                  (t (go loop))))))


(dv %prevfn% " ")
(dv %trcflg t)
   
(def attach
     (lambda 
      (x y)
      (cond ((dtpr y) (rplacd y (cons (car y) (cdr y))) (rplaca y x))
            (t (eprint y) (error '"IS AN ATOM, CAN'T BE ATTACHED TO")))))

(dv %changes ())

(def dremove
   (lambda (x l)
	   (cond ((atom l) nil)
		 ((eq x (car l))
		  (cond ((cdr l)
			 (rplaca l (cadr l))
			 (rplacd l (cddr l))
			 (dremove x l))))
		 (t (prog (z)
			  (setq z l)
		    lp    (cond ((atom (cdr l)) (return z))
				((eq x (cadr l)) (rplacd l (cddr l)))
				(t (setq l (cdr l))))
			  (go lp))))))
(def dreverse
     (lambda (l)
      (prog (l1 y z)
            (setq l1 l)
       l1   (cond
             ((atom (setq y l))
              (cond ((or (null z) (null (cdr z))) (return z))
                    ((null (cddr z))
                     (setq y (car l1))
                     (rplaca l1 (car z))
                     (rplaca z y)
                     (rplacd l1 z)
                     (rplacd z nil)
                     (return l1))
                    (t (rplacd (Cnth z (sub1 (length z))) z)
                       (setq y (car l1))
                       (rplaca l1 (car z))
                       (rplaca z y)
                       (rplacd l1 (cdr z))
                       (rplacd z nil)
                       (return l1)))))
            (setq l (cdr l))
            (setq z (rplacd y z))
            (go l1))))

(def dsubst
     (lambda (x y z)
      (prog (b)
            (cond ((eq y (setq b z)) (return (copy x))))
       lp   (cond ((atom z) (return b))
                  ((cond ((symbolp y) (eq y (car z))) (t (equal y (car z))))
                   (rplaca z (copy x)))
                  (t (dsubst x y (car z))))
            (cond ((and y (eq y (cdr z))) (rplacd z (copy x)) (return b)))
            (setq z (cdr z))
            (go lp))))

(putd 'eqstr (getd 'equal))

; where are the functions this calls??
(def every
     (lambda 
      (everyx everyfn1 everyfn2)
      (prog nil
       a    (cond ((null everyx) (return t))
                  ((funcall everyfn1 (car everyx))
                   (setq everyx
                         (cond ((null everyfn2) (cdr everyx))
                               (t (funcall everyfn2 everyx))))
                   (go a))
                  (t (return nil))))))
(def insert
     (lambda 
      (x l comparefn nodups)
      (cond ((null l) (list x))
            ((atom l)
             (eprint l)
             (error '"is an atom, can't be inserted into"))
            (t (cond
                ((null comparefn) (setq comparefn (function alphalessp))))
               (prog (l1 n n1 y)
                     (setq l1 l)
                     (setq n (length l))
                a    (setq n1 (*quo (add1 n) 2))
                     (setq y (Cnth l1 n1))
                     (cond ((< n 3)
                            (cond ((funcall comparefn x (car y))
                                   (cond
                                    ((not
                                      (and nodups (equal x (car y))))
                                     (rplacd y (cons (car y) (cdr y)))
                                     (rplaca y x))))
                                  ((eq n 1) (rplacd y (cons x (cdr y))))
                                  ((funcall comparefn x (cadr y))
                                   (cond
                                    ((not
                                      (and nodups (equal x (cadr y))))
                                     (rplacd (cdr y)
                                             (cons (cadr y) (cddr y)))
                                     (rplaca (cdr y) x))))
                                  (t (rplacd (cdr y) (cons x (cddr y))))))
                           ((funcall comparefn x (car y))
                            (cond
                             ((not (and nodups (equal x (car y))))
                              (setq n (sub1 n1))
                              (go a))))
                           (t (setq l1 (cdr y)) (setq n (- n n1)) (go a))))
               l))))

(def kwote (lambda (x) (list 'quote x)))

(def lconc
     (lambda 
      (ptr x)
      (prog (xx)
            (return
             (cond ((atom x) ptr)
                   (t (setq xx (last x))
                      (cond ((atom ptr) (cons x xx))
                            ((dtpr (cdr ptr))
                             (rplacd (cdr ptr) x)
                             (rplacd ptr xx))
                            (t (rplaca (rplacd ptr xx) x)))))))))

(def ldiff
     (lambda 
      (x y)
      (cond ((eq x y) nil)
            ((null y) x)
            (t
             (prog (v z)
                   (setq z (setq v (ncons (car x))))
              loop (setq x (cdr x))
                   (cond ((eq x y) (return z))
                         ((null x) (error '"NOT A TAIL - LDIFF")))
                   (setq v (cdr (rplacd v (ncons (car x)))))
                   (go loop))))))


(def lsubst
     (lambda 
      (x y z)
      (cond ((null z) nil)
            ((atom z) (cond ((eq y z) x) (t z)))
            ((equal y (car z)) (nconc (copy x) (lsubst x y (cdr z))))
            (t (cons (lsubst x y (car z)) (lsubst x y (cdr z)))))))

(def memcdr
     (lambda 
      (%x% %y%)
      (prog nil
       l1   (cond ((eq %x% (cdr %y%)) (return t))
                  ((eq %x% %y%) (return nil)))
            (setq %x% (cdr %x%))
            (go l1))))

(def merge
     (lambda 
      (a b %%cfn)
      (cond ((null %%cfn) (setq %%cfn (function alphalessp))))
      (merge1 a b)))

(def merge1
     (lambda 
      (a b)
      (cond ((null a) b)
            ((null b) a)
            (t
             (prog (val end)
                   (setq val
                         (setq end
                               (cond ((funcall %%cfn (car a) (car b))
                                      (prog1 a (setq a (cdr a))))
                                     (t (prog1 b (setq b (cdr b)))))))
              loop (cond ((null a) (rplacd end b) (return val))
                         ((null b) (rplacd end a) (return val))
                         ((funcall %%cfn (car a) (car b))
                          (rplacd end a)
                          (setq a (cdr a)))
                         (t (rplacd end b) (setq b (cdr b))))
                   (setq end (cdr end))
                   (go loop))))))

(def notany
     (lambda (somex somefn1 somefn2) (not (some somex somefn1 somefn2))))

(def notevery
     (lambda 
      (everyx everyfn1 everyfn2)
      (not (every everyx everyfn1 everyfn2))))

(def Cnth
     (lambda 
      (x n)
      (cond ((> 1 n) (cons nil x))
            (t
             (prog nil
              lp   (cond ((or (atom x) (eq n 1)) (return x)))
                   (setq x (cdr x))
                   (setq n (sub1 n))
                   (go lp))))))

(def nthchar
     (lambda 
      (x n)
      (cond ((plusp n) (car (Cnth (explodec x) n)))
            ((minusp n) (car (Cnth (reverse (explodec x)) (minus n))))
            ((zerop n) nil))))

(def prinlev
     (lambda 
      ($%x $%n)
      (cond ((not (dtpr $%x)) (print $%x))
            ((and %trcflg (eq (car $%x) 'evl-trace) (dtpr (cdr $%x)))
             (prinlev (cadr $%x) $%n))
            ((and %trcflg
                  (eq (car $%x) '\#)
                  (dtpr (cdr $%x))
                  (dtpr (cddr $%x)))
             (prinlev (caddr $%x) $%n))
            ((eq %prevfn% $%x) (princ '//\#//))
            ((eq $%n 0) (princ '"& "))
            (t
             (prog ($%kk $%cl)
                   (princ
                    (cond ($%dotflg (setq $%dotflg nil) '"... ")
                          (t '"(")))
                   (prinlev (car $%x) (sub1 $%n))
                   (setq $%kk $%x)
              lp   (cond
                    ((memcdr $%x $%kk)
                     (cond ($%cl (princ '" ...]") (return nil))
                           (t (setq $%cl t)))))
                   (cond ((not (*** eq (cdr $%kk) (unbound)))
                          (setq $%kk (cdr $%kk)))
                         (t (princ '" . unbound)") (return nil)))
                   (cond ((null $%kk) (princ '")") (return nil))
                         ((atom $%kk)
                          (princ '" . ")
                          (patom $%kk)
                          (princ '")")
                          (return nil)))
                   (princ '" ")
                   (prinlev (car $%kk) (sub1 $%n))
                   (go lp))))))

(def printlev (lambda ($%x $%n) (terpri) (prinlev $%x $%n) $%x))


(def remove
     (lambda 
      (elt list)
      (cond ((atom list) list)
            ((equal (car list) elt) (remove elt (cdr list)))
            ((cons (car list) (remove elt (cdr list)))))))

(def some
     (lambda 
      (somex somefn1 somefn2)
      (prog nil
       a    (cond ((null somex) (return nil))
                  ((funcall somefn1 (car somex)) (return somex))
                  (t (setq somex
                           (cond ((null somefn2) (cdr somex))
                                 (t (funcall somefn2 somex))))
                     (go a))))))

; this probably should have another names since is   ****
; just a duplication of an existing function and since it has a
; default second arg which I believe is not documented.
(def sort
     (lambda 
      (%%l %%cfn)
      (prog (val n)
            (cond ((null %%cfn) (setq %%cfn (function alphalessp))))
            (setq n 0)
            (setq val (sort1 0))
       loop (cond ((null %%l) (return val))
                  (t (setq val (merge1 val (sort1 n)))
                     (setq n (add1 n))
                     (go loop))))))

(def sort1
     (lambda 
      (n)
      (cond ((null %%l) nil)
            ((zerop n)
             (prog (run end)
                   (setq run %%l)
              loop (setq end %%l)
                   (setq %%l (cdr %%l))
                   (cond ((or (null %%l)
                              (not (funcall %%cfn (car end) (car %%l))))
                          (rplacd end nil)
                          (return run))
                         (t (go loop)))))
            (t (merge1 (sort1 (sub1 n)) (sort1 (sub1 n)))))))

(def subpair
     (lambda 
      (old new expr)
      (cond (old (subpr expr old (or new '(nil)))) (t expr))))

(def subpr
     (lambda 
      (expr l1 l2)
      (prog (d a)
            (cond ((atom expr) (go lp))
                  ((setq d (cdr expr)) (setq d (subpr d l1 l2))))
            (setq a (subpr (car expr) l1 l2))
            (return
             (cond ((or (neq a (car expr)) (neq d (cdr expr))) (cons a d))
                   (t expr)))
       lp   (cond ((null l1) (return expr))
                  (l2 (cond ((eq expr (car l1)) (return (car l2)))))
                  (t (cond ((eq expr (caar l1)) (return (cdar l1))))))
            (setq l1 (cdr l1))
            (and l2 (setq l2 (or (cdr l2) '(nil))))
            (go lp))))

(def tailp
     (lambda 
      (x y)
      (and x
           (prog nil
            lp   (cond ((atom y) (return nil)) ((eq x y) (return x)))
                 (setq y (cdr y))
                 (go lp)))))

(def tconc
     (lambda 
      (p x)
      (cond ((atom p) (cons (setq x (ncons x)) x))
            ((dtpr (cdr p)) (rplacd p (cdr (rplacd (cdr p) (ncons x)))))
            (t (rplaca p (cdr (rplacd p (ncons x))))))))

(def ttyesno (lambda nil (yesno (read))))

(def yesno (lambda (x) (selectq x ((t y yes) t) ((nil n no) nil) x)))

; this really duplicates a function in auxfns1.l but this does more
; error checking.
(defun nth (N L)
	(cond ((null L)nil)
	      (t(do ((LCDR L (cdr LCDR))
		     (COUNT N (1- COUNT)))
		    ((or (and (atom LCDR) LCDR
   		              (err '"non-proper list passed to nth"))
		         (or (lessp COUNT 0)(zerop COUNT)))
		     (car LCDR))
		    nil))))
(declare (special piport))
(def dc-dskin			; LWE Hacking to compile OK
   (nlambda (args)
	    (prog (tmp tmp1 tmp2)
		  (setq tmp
			(prog (c cc)
			      (setq cc (get (car args) 'comment))
			      loop
			      (cond ((not cc)(return nil)))
			      (setq c (car cc))
			      (cond ((eq (car c)(cadr args))
				     (return nil)))
			      (setq cc (cdr cc))
			      (go loop)))
		  (setq tmp2 piport)
		  (setq tmp1 (get-comment 27 tmp2))
		  (cond (tmp  (disgusting tmp
					  (cons (cadr args)
						(cons (caddr args) tmp1))))
			(t (putprop (car args)
				    (cons (cons (cadr args)
						(cons (caddr args) tmp1))
					  (get (car args) 'comment))
				    'comment)))
		  (mark!changed (car args))
		  (return nil))))

(def disgusting (lambda (a b) ; (rplaca a b)))
b))

(def get-comment
  (lambda (stopper piport)
    (prog (ans line)
          (cond ((eq 10 (tyipeek piport)) (tyi piport)))
     l:   (setq line nil)
;          (until (member (car line) (list 10 stopper))
;                 (setq line (cons (tyi piport) line)))
	   (prog nil loop
		(cond ((member (car line)(list 10 stopper))
		       (return nil)))
	        (setq line (cons (tyi piport) line))
		(go loop))
          (setq ans (cons (implode (dreverse (cdr line))) ans))
          (cond ((eq (car line) 10) (go l:)) (t (return (dreverse ans)))))))
Commit	Line	Data
5ffa1c4c C	1	(setq rcs-cmufncs-
	2	"$Header: /usr/lib/lisp/cmufncs.l,v 1.1 83/01/29 18:34:20 jkf Exp $")
	3
	4	(eval-when (compile eval) (load 'cmumacs))
	5
	6	(declare (special filelst %changes $%dotflg %prevfn% %%cfn part %%l
	7	lastword %trcflg form fn))
	8	(def tab (lexpr (n)
	9	(prog (nn prt) (setq nn (arg 1))
	10	(cond ((> n 1)(setq prt (arg 2))))
	11	(cond ((> (nwritn prt) nn) (terpri prt)))
	12	(printblanks (- nn (nwritn prt)) prt))))
	13
	14
	15	(dv $%dotflg nil)
	16	(def %lineread
	17	(lambda
	18	(chan)
	19	(prog (ans)
	20	loop (setq ans (cons (read chan 'EOF) ans))
	21	(cond ((eq (car ans) 'EOF) (return (reverse (cdr ans)))))
	22	loop2(cond ((eq 10 (tyipeek chan)) (return (reverse ans)))
	23	((memq (tyipeek chan) '(41 93))
	24	(tyi chan)
	25	(go loop2))
	26	(t (go loop))))))
	27
	28
	29	(dv %prevfn% " ")
	30	(dv %trcflg t)
	31
	32	(def attach
	33	(lambda
	34	(x y)
	35	(cond ((dtpr y) (rplacd y (cons (car y) (cdr y))) (rplaca y x))
	36	(t (eprint y) (error '"IS AN ATOM, CAN'T BE ATTACHED TO")))))
	37
	38	(dv %changes ())
	39
	40	(def dremove
	41	(lambda (x l)
	42	(cond ((atom l) nil)
	43	((eq x (car l))
	44	(cond ((cdr l)
	45	(rplaca l (cadr l))
	46	(rplacd l (cddr l))
	47	(dremove x l))))
	48	(t (prog (z)
	49	(setq z l)
	50	lp (cond ((atom (cdr l)) (return z))
	51	((eq x (cadr l)) (rplacd l (cddr l)))
	52	(t (setq l (cdr l))))
	53	(go lp))))))
	54	(def dreverse
	55	(lambda (l)
	56	(prog (l1 y z)
	57	(setq l1 l)
	58	l1 (cond
	59	((atom (setq y l))
	60	(cond ((or (null z) (null (cdr z))) (return z))
	61	((null (cddr z))
	62	(setq y (car l1))
	63	(rplaca l1 (car z))
	64	(rplaca z y)
65	(rplacd l1 z)
66	(rplacd z nil)
67	(return l1))
68	(t (rplacd (Cnth z (sub1 (length z))) z)
69	(setq y (car l1))
70	(rplaca l1 (car z))
71	(rplaca z y)
72	(rplacd l1 (cdr z))
73	(rplacd z nil)
74	(return l1)))))
75	(setq l (cdr l))
76	(setq z (rplacd y z))
77	(go l1))))
78
79	(def dsubst
80	(lambda (x y z)
81	(prog (b)
82	(cond ((eq y (setq b z)) (return (copy x))))
83	lp (cond ((atom z) (return b))
84	((cond ((symbolp y) (eq y (car z))) (t (equal y (car z))))
85	(rplaca z (copy x)))
86	(t (dsubst x y (car z))))
87	(cond ((and y (eq y (cdr z))) (rplacd z (copy x)) (return b)))
88	(setq z (cdr z))
89	(go lp))))
90
91	(putd 'eqstr (getd 'equal))
92
93	; where are the functions this calls??
94	(def every
95	(lambda
96	(everyx everyfn1 everyfn2)
97	(prog nil
98	a (cond ((null everyx) (return t))
99	((funcall everyfn1 (car everyx))
100	(setq everyx
101	(cond ((null everyfn2) (cdr everyx))
102	(t (funcall everyfn2 everyx))))
103	(go a))
104	(t (return nil))))))
105	(def insert
106	(lambda
107	(x l comparefn nodups)
108	(cond ((null l) (list x))
109	((atom l)
110	(eprint l)
111	(error '"is an atom, can't be inserted into"))
112	(t (cond
113	((null comparefn) (setq comparefn (function alphalessp))))
114	(prog (l1 n n1 y)
115	(setq l1 l)
116	(setq n (length l))
117	a (setq n1 (*quo (add1 n) 2))
118	(setq y (Cnth l1 n1))
119	(cond ((< n 3)
120	(cond ((funcall comparefn x (car y))
121	(cond
122	((not
123	(and nodups (equal x (car y))))
124	(rplacd y (cons (car y) (cdr y)))
125	(rplaca y x))))
126	((eq n 1) (rplacd y (cons x (cdr y))))
127	((funcall comparefn x (cadr y))
128	(cond
129	((not
130	(and nodups (equal x (cadr y))))
131	(rplacd (cdr y)
132	(cons (cadr y) (cddr y)))
133	(rplaca (cdr y) x))))
134	(t (rplacd (cdr y) (cons x (cddr y))))))
135	((funcall comparefn x (car y))
136	(cond
137	((not (and nodups (equal x (car y))))
138	(setq n (sub1 n1))
139	(go a))))
140	(t (setq l1 (cdr y)) (setq n (- n n1)) (go a))))
141	l))))
142
143	(def kwote (lambda (x) (list 'quote x)))
144
145	(def lconc
146	(lambda
147	(ptr x)
148	(prog (xx)
149	(return
150	(cond ((atom x) ptr)
151	(t (setq xx (last x))
152	(cond ((atom ptr) (cons x xx))
153	((dtpr (cdr ptr))
154	(rplacd (cdr ptr) x)
155	(rplacd ptr xx))
156	(t (rplaca (rplacd ptr xx) x)))))))))
157
158	(def ldiff
159	(lambda
160	(x y)
161	(cond ((eq x y) nil)
162	((null y) x)
163	(t
164	(prog (v z)
165	(setq z (setq v (ncons (car x))))
166	loop (setq x (cdr x))
167	(cond ((eq x y) (return z))
168	((null x) (error '"NOT A TAIL - LDIFF")))
169	(setq v (cdr (rplacd v (ncons (car x)))))
170	(go loop))))))
171
172
173	(def lsubst
174	(lambda
175	(x y z)
176	(cond ((null z) nil)
177	((atom z) (cond ((eq y z) x) (t z)))
178	((equal y (car z)) (nconc (copy x) (lsubst x y (cdr z))))
179	(t (cons (lsubst x y (car z)) (lsubst x y (cdr z)))))))
180
181	(def memcdr
182	(lambda
183	(%x% %y%)
184	(prog nil
185	l1 (cond ((eq %x% (cdr %y%)) (return t))
186	((eq %x% %y%) (return nil)))
187	(setq %x% (cdr %x%))
188	(go l1))))
189
190	(def merge
191	(lambda
192	(a b %%cfn)
193	(cond ((null %%cfn) (setq %%cfn (function alphalessp))))
194	(merge1 a b)))
195
196	(def merge1
197	(lambda
198	(a b)
199	(cond ((null a) b)
200	((null b) a)
201	(t
202	(prog (val end)
203	(setq val
204	(setq end
205	(cond ((funcall %%cfn (car a) (car b))
206	(prog1 a (setq a (cdr a))))
207	(t (prog1 b (setq b (cdr b)))))))
208	loop (cond ((null a) (rplacd end b) (return val))
209	((null b) (rplacd end a) (return val))
210	((funcall %%cfn (car a) (car b))
211	(rplacd end a)
212	(setq a (cdr a)))
213	(t (rplacd end b) (setq b (cdr b))))
214	(setq end (cdr end))
215	(go loop))))))
216
217	(def notany
218	(lambda (somex somefn1 somefn2) (not (some somex somefn1 somefn2))))
219
220	(def notevery
221	(lambda
222	(everyx everyfn1 everyfn2)
223	(not (every everyx everyfn1 everyfn2))))
224
225	(def Cnth
226	(lambda
227	(x n)
228	(cond ((> 1 n) (cons nil x))
229	(t
230	(prog nil
231	lp (cond ((or (atom x) (eq n 1)) (return x)))
232	(setq x (cdr x))
233	(setq n (sub1 n))
234	(go lp))))))
235
236	(def nthchar
237	(lambda
238	(x n)
239	(cond ((plusp n) (car (Cnth (explodec x) n)))
240	((minusp n) (car (Cnth (reverse (explodec x)) (minus n))))
241	((zerop n) nil))))
242
243	(def prinlev
244	(lambda
245	($%x $%n)
246	(cond ((not (dtpr $%x)) (print $%x))
247	((and %trcflg (eq (car $%x) 'evl-trace) (dtpr (cdr $%x)))
248	(prinlev (cadr $%x) $%n))
249	((and %trcflg
250	(eq (car $%x) '\#)
251	(dtpr (cdr $%x))
252	(dtpr (cddr $%x)))
253	(prinlev (caddr $%x) $%n))
254	((eq %prevfn% $%x) (princ '//\#//))
255	((eq $%n 0) (princ '"& "))
256	(t
257	(prog ($%kk $%cl)
258	(princ
259	(cond ($%dotflg (setq $%dotflg nil) '"... ")
260	(t '"(")))
261	(prinlev (car $%x) (sub1 $%n))
262	(setq $%kk $%x)
263	lp (cond
264	((memcdr $%x $%kk)
265	(cond ($%cl (princ '" ...]") (return nil))
266	(t (setq $%cl t)))))
267	(cond ((not (*** eq (cdr $%kk) (unbound)))
268	(setq $%kk (cdr $%kk)))
269	(t (princ '" . unbound)") (return nil)))
270	(cond ((null $%kk) (princ '")") (return nil))
271	((atom $%kk)
272	(princ '" . ")
273	(patom $%kk)
274	(princ '")")
275	(return nil)))
276	(princ '" ")
277	(prinlev (car $%kk) (sub1 $%n))
278	(go lp))))))
279
280	(def printlev (lambda ($%x $%n) (terpri) (prinlev $%x $%n) $%x))
281
282
283
284	(def remove
285	(lambda
286	(elt list)
287	(cond ((atom list) list)
288	((equal (car list) elt) (remove elt (cdr list)))
289	((cons (car list) (remove elt (cdr list)))))))
290
291	(def some
292	(lambda
293	(somex somefn1 somefn2)
294	(prog nil
295	a (cond ((null somex) (return nil))
296	((funcall somefn1 (car somex)) (return somex))
297	(t (setq somex
298	(cond ((null somefn2) (cdr somex))
299	(t (funcall somefn2 somex))))
300	(go a))))))
301
302	; this probably should have another names since is ****
303	; just a duplication of an existing function and since it has a
304	; default second arg which I believe is not documented.
305	(def sort
306	(lambda
307	(%%l %%cfn)
308	(prog (val n)
309	(cond ((null %%cfn) (setq %%cfn (function alphalessp))))
310	(setq n 0)
311	(setq val (sort1 0))
312	loop (cond ((null %%l) (return val))
313	(t (setq val (merge1 val (sort1 n)))
314	(setq n (add1 n))
315	(go loop))))))
316
317	(def sort1
318	(lambda
319	(n)
320	(cond ((null %%l) nil)
321	((zerop n)
322	(prog (run end)
323	(setq run %%l)
324	loop (setq end %%l)
325	(setq %%l (cdr %%l))
326	(cond ((or (null %%l)
327	(not (funcall %%cfn (car end) (car %%l))))
328	(rplacd end nil)
329	(return run))
330	(t (go loop)))))
331	(t (merge1 (sort1 (sub1 n)) (sort1 (sub1 n)))))))
332
333	(def subpair
334	(lambda
335	(old new expr)
336	(cond (old (subpr expr old (or new '(nil)))) (t expr))))
337
338	(def subpr
339	(lambda
340	(expr l1 l2)
341	(prog (d a)
342	(cond ((atom expr) (go lp))
343	((setq d (cdr expr)) (setq d (subpr d l1 l2))))
344	(setq a (subpr (car expr) l1 l2))
345	(return
346	(cond ((or (neq a (car expr)) (neq d (cdr expr))) (cons a d))
347	(t expr)))
348	lp (cond ((null l1) (return expr))
349	(l2 (cond ((eq expr (car l1)) (return (car l2)))))
350	(t (cond ((eq expr (caar l1)) (return (cdar l1))))))
351	(setq l1 (cdr l1))
352	(and l2 (setq l2 (or (cdr l2) '(nil))))
353	(go lp))))
354
355	(def tailp
356	(lambda
357	(x y)
358	(and x
359	(prog nil
360	lp (cond ((atom y) (return nil)) ((eq x y) (return x)))
361	(setq y (cdr y))
362	(go lp)))))
363
364	(def tconc
365	(lambda
366	(p x)
367	(cond ((atom p) (cons (setq x (ncons x)) x))
368	((dtpr (cdr p)) (rplacd p (cdr (rplacd (cdr p) (ncons x)))))
369	(t (rplaca p (cdr (rplacd p (ncons x))))))))
370
371	(def ttyesno (lambda nil (yesno (read))))
372
373	(def yesno (lambda (x) (selectq x ((t y yes) t) ((nil n no) nil) x)))
374
375	; this really duplicates a function in auxfns1.l but this does more
376	; error checking.
377	(defun nth (N L)
378	(cond ((null L)nil)
379	(t(do ((LCDR L (cdr LCDR))
380	(COUNT N (1- COUNT)))
381	((or (and (atom LCDR) LCDR
382	(err '"non-proper list passed to nth"))
383	(or (lessp COUNT 0)(zerop COUNT)))
384	(car LCDR))
385	nil))))
386	(declare (special piport))
387	(def dc-dskin ; LWE Hacking to compile OK
388	(nlambda (args)
389	(prog (tmp tmp1 tmp2)
390	(setq tmp
391	(prog (c cc)
392	(setq cc (get (car args) 'comment))
393	loop
394	(cond ((not cc)(return nil)))
395	(setq c (car cc))
396	(cond ((eq (car c)(cadr args))
397	(return nil)))
398	(setq cc (cdr cc))
399	(go loop)))
400	(setq tmp2 piport)
401	(setq tmp1 (get-comment 27 tmp2))
402	(cond (tmp (disgusting tmp
403	(cons (cadr args)
404	(cons (caddr args) tmp1))))
405	(t (putprop (car args)
406	(cons (cons (cadr args)
407	(cons (caddr args) tmp1))
408	(get (car args) 'comment))
409	'comment)))
410	(mark!changed (car args))
411	(return nil))))
412
413	(def disgusting (lambda (a b) ; (rplaca a b)))
414	b))
415
416	(def get-comment
417	(lambda (stopper piport)
418	(prog (ans line)
419	(cond ((eq 10 (tyipeek piport)) (tyi piport)))
420	l: (setq line nil)
421	; (until (member (car line) (list 10 stopper))
422	; (setq line (cons (tyi piport) line)))
423	(prog nil loop
424	(cond ((member (car line)(list 10 stopper))
425	(return nil)))
426	(setq line (cons (tyi piport) line))
427	(go loop))
428	(setq ans (cons (implode (dreverse (cdr line))) ans))
429	(cond ((eq (car line) 10) (go l:)) (t (return (dreverse ans)))))))