"$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))
(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))))
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))
(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")))))
lp (cond ((atom (cdr l)) (return z))
((eq x (cadr l)) (rplacd l (cddr l)))
(cond ((or (null z) (null (cdr z))) (return z))
(t (rplacd (Cnth z (sub1 (length z))) z)
(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))))
(t (dsubst x y (car z))))
(cond ((and y (eq y (cdr z))) (rplacd z (copy x)) (return b)))
(putd 'eqstr (getd 'equal))
; where are the functions this calls??
(everyx everyfn1 everyfn2)
a (cond ((null everyx) (return t))
((funcall everyfn1 (car everyx))
(cond ((null everyfn2) (cdr everyx))
(t (funcall everyfn2 everyx))))
(cond ((null l) (list x))
(error '"is an atom, can't be inserted into"))
((null comparefn) (setq comparefn (function alphalessp))))
a (setq n1 (*quo (add1 n) 2))
(cond ((funcall comparefn x (car y))
(and nodups (equal x (car y))))
(rplacd y (cons (car y) (cdr y)))
((eq n 1) (rplacd y (cons x (cdr y))))
((funcall comparefn x (cadr y))
(and nodups (equal x (cadr y))))
(cons (cadr y) (cddr y)))
(t (rplacd (cdr y) (cons x (cddr y))))))
((funcall comparefn x (car y))
((not (and nodups (equal x (car y))))
(t (setq l1 (cdr y)) (setq n (- n n1)) (go a))))
(def kwote (lambda (x) (list 'quote x)))
(cond ((atom ptr) (cons x xx))
(t (rplaca (rplacd ptr xx) x)))))))))
(setq z (setq v (ncons (car x))))
(cond ((eq x y) (return z))
((null x) (error '"NOT A TAIL - LDIFF")))
(setq v (cdr (rplacd v (ncons (car x)))))
((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)))))))
l1 (cond ((eq %x% (cdr %y%)) (return t))
((eq %x% %y%) (return nil)))
(cond ((null %%cfn) (setq %%cfn (function alphalessp))))
(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))
(t (rplacd end b) (setq b (cdr b))))
(lambda (somex somefn1 somefn2) (not (some somex somefn1 somefn2))))
(everyx everyfn1 everyfn2)
(not (every everyx everyfn1 everyfn2))))
(cond ((> 1 n) (cons nil x))
lp (cond ((or (atom x) (eq n 1)) (return x)))
(cond ((plusp n) (car (Cnth (explodec x) n)))
((minusp n) (car (Cnth (reverse (explodec x)) (minus n))))
(cond ((not (dtpr $%x)) (print $%x))
((and %trcflg (eq (car $%x) 'evl-trace) (dtpr (cdr $%x)))
(prinlev (cadr $%x) $%n))
(prinlev (caddr $%x) $%n))
((eq %prevfn% $%x) (princ '//\#//))
((eq $%n 0) (princ '"& "))
(cond ($%dotflg (setq $%dotflg nil) '"... ")
(prinlev (car $%x) (sub1 $%n))
(cond ($%cl (princ '" ...]") (return nil))
(cond ((not (*** eq (cdr $%kk) (unbound)))
(t (princ '" . unbound)") (return nil)))
(cond ((null $%kk) (princ '")") (return nil))
(prinlev (car $%kk) (sub1 $%n))
(def printlev (lambda ($%x $%n) (terpri) (prinlev $%x $%n) $%x))
((equal (car list) elt) (remove elt (cdr list)))
((cons (car list) (remove elt (cdr list)))))))
a (cond ((null somex) (return nil))
((funcall somefn1 (car somex)) (return somex))
(cond ((null somefn2) (cdr somex))
(t (funcall somefn2 somex))))
; 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.
(cond ((null %%cfn) (setq %%cfn (function alphalessp))))
loop (cond ((null %%l) (return val))
(t (setq val (merge1 val (sort1 n)))
(not (funcall %%cfn (car end) (car %%l))))
(t (merge1 (sort1 (sub1 n)) (sort1 (sub1 n)))))))
(cond (old (subpr expr old (or new '(nil)))) (t expr))))
(cond ((atom expr) (go lp))
((setq d (cdr expr)) (setq d (subpr d l1 l2))))
(setq a (subpr (car expr) l1 l2))
(cond ((or (neq a (car expr)) (neq d (cdr expr))) (cons a d))
lp (cond ((null l1) (return expr))
(l2 (cond ((eq expr (car l1)) (return (car l2)))))
(t (cond ((eq expr (caar l1)) (return (cdar l1))))))
(and l2 (setq l2 (or (cdr l2) '(nil))))
lp (cond ((atom y) (return nil)) ((eq x y) (return 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
(t(do ((LCDR L (cdr LCDR))
((or (and (atom LCDR) LCDR
(err '"non-proper list passed to nth"))
(or (lessp COUNT 0)(zerop COUNT)))
(declare (special piport))
(def dc-dskin ; LWE Hacking to compile OK
(setq cc (get (car args) 'comment))
(cond ((not cc)(return nil)))
(cond ((eq (car c)(cadr args))
(setq tmp1 (get-comment 27 tmp2))
(cond (tmp (disgusting tmp
(cons (caddr args) tmp1))))
(cons (caddr args) tmp1))
(get (car args) 'comment))
(mark!changed (car args))
(def disgusting (lambda (a b) ; (rplaca a b)))
(cond ((eq 10 (tyipeek piport)) (tyi piport)))
; (until (member (car line) (list 10 stopper))
; (setq line (cons (tyi piport) line)))
(cond ((member (car line)(list 10 stopper))
(setq line (cons (tyi piport) line))
(setq ans (cons (implode (dreverse (cdr line))) ans))
(cond ((eq (car line) 10) (go l:)) (t (return (dreverse ans)))))))