![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to cmufncs.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 cmufncs.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 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)))))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.