;;; cmu file package.
;;;
(setq rcs-cmufile-
"$Header: /usr/lib/lisp/cmufile.l,v 1.1 83/01/29 18:34:10 jkf Exp $")
(eval-when (compile eval)
(load 'cmumacs)
(load 'cmufncs)
)
(declare (special $cur$ dc-switch piport %indent dc-switch
vars body form var init label part incr limit
getdeftable $outport$ tlmacros f tmp))
(declare (nlambda msg))
(declare
(special %changes
def-comment
filelst
found
getdefchan
getdefprops
history
historylength
args
i
l
lasthelp
prop
special
special
tlbuffer
z))
(dv dc-switch dc-define)
(dv %indent 0)
(dv *digits ("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
(dv *letters (a b c d e f g h i j k l m n o p q r s t u v w x y z))
(def changes
(lambda nil
(changes1)
(for-each f
filelst
(cond
((get f 'changes)
(terpri)
(princ f)
(tab 15)
(princ (get f 'changes)))))
(cond
(%changes (terpri) (princ '<no-file>) (tab 15) (princ %changes)))
nil))
(def changes1
(lambda nil
(cond ((null %changes) nil)
(t
(prog (found prop)
(for-each f
filelst
(setq found
(cons (set-of fn
(cons (concat f 'fns)
(eval
(concat f
'fns)))
(memq fn %changes))
found))
(setq prop (get f 'changes))
(for-each fn
(car found)
(setq prop (insert fn prop nil t)))
(putprop f prop 'changes))
(setq found (apply 'append found))
(setq %changes (set-of fn %changes (not (memq fn found)))))))))
(def dc
(nlambda (args)
(eval (cons dc-switch args]
(def dc-define
(nlambda (args)
(msg "Enter comment followed by <esc>" (N 1))
(drain piport)
(eval (cons 'dc-dskin args]
(def dc-help
(nlambda (args)
(cond
((eval (cons 'helpfilter (cons (car args) (caddr args))))
(transprint getdefchan)))))
(def dskin
(nlambda (files)
(mapc (function
(lambda (f)
(prog nil
(setq dc-switch 'dc-dskin)
(file f)
(load f)
(changes1)
(putprop f nil 'changes)
(setq dc-switch 'dc-define)
)))
files]
(***
The new version of dskout (7/26/80) tries to keep backup versions It returns
the setof its arguments that were successfully written If it can not write
a file (typically because of protection restrictions) it offers to (try to)
write a copy to /tmp A file written to /tmp is not considered to have been
successfully written (and changes will not consider it to be up-to-date) )
(def dskout
(nlambda (files)
(changes1)
(set-of f
files
(prog (ffns p tmp)
(cond ((atom (errset (setq p (infile f)) nil))
(msg "creating " f N D))
(t (close p)
(cond ((zerop
(eval
(list 'exec
'mv
f
(setq tmp
(concat f '|.back|)))))
(msg "old version moved to "
tmp N D))
(t (msg
"Unable to back up "
f
" - continue? (y/n) " D)
(cond ((not (ttyesno)) (return nil)))))))
(cond
((atom
(errset (apply (function pp)
(cons (list 'F f)
(cons (setq ffns
(concat f
'fns))
(eval ffns))))
nil))
(msg
"Unable to write "
f
" - try to put it on /tmp? (y/n) " D)
(cond
((ttyesno)
(setq f (explode f))
(while (memq '/ f)
(setq f (cdr (memq '/ f))))
(setq f
(apply (function concat)
(cons '/tmp/ f)))
(cond ((atom
(errset
(apply (function pp)
(cons (list 'F f)
(cons ffns (eval ffns))))))
(msg
"Unable to create "
f
" - I give up! " N D ))
(t (msg f " written " N D )))))
(return nil)))
(putprop f nil 'changes)
(return t)))))
(def dskouts
(lambda nil
(changes1)
(apply (function dskout) (set-of f filelst (get f 'changes)))))
(def evl-trace
(nlambda (exp)
(prog (val)
(tab %indent)
(prinlev (car exp) 2)
((lambda (%indent) (setq val (eval (car exp)))) (+ 2 %indent))
(tab %indent)
(prinlev val 2)
(return val))))
(def file
(lambda (name)
(setq filelst (insert name filelst nil t))
(cond
((not (boundp (concat name 'fns)))
(set (concat name 'fns) nil)))
name))
(def getdef
(nlambda (%%l)
(prog (x u getdefchan found)
(setq getdefchan (infile (car %%l)))
l (cond ((atom
(setq u
(errset
(prog (x y z)
(cond
((eq (tyipeek getdefchan) -1)
(err 'EOF)))
(cond
((memq (tyipeek getdefchan)
'(12 13))
(tyi getdefchan)))
(return
(cond
((memq (tyipeek getdefchan)
'(40 91))
(tyi getdefchan)
(cond
((and (symbolp
(setq y (ratom getdefchan)))
(cond (t (comment - what about
intern?)
(setq x y)
t)
((neq y
(setq x
(intern y)))
t)
(t (remob1 x) nil))
(assoc x getdeftable)
(or (setq z (ratom getdefchan))
t)
(some (cdr %%l)
(function
(lambda (x)
(matchq x z)))
nil)
(cond ((symbolp z)
(setq y z)
t)
(t (setq y z) t))
(cond ((memq y found))
((setq found
(cons y found))))
(not
(cond
((memq (tyipeek
getdefchan)
'(40 91))
(print x)
(terpri)
(princ y)
(tyo 32)
(princ
'" -- bad format")
t))))
(cons x
(cons y
(cond ((memq (tyipeek
getdefchan)
'(41
93))
(tyi
getdefchan)
nil)
(t (untyi 40
getdefchan)
(read
getdefchan))))))))))))))
(close getdefchan)
(return found))
(t (setq x (car u))
(*** free u)
(setq u nil)
(cond
((not (atom x))
(apply (cdr (assoc (car x) getdeftable)) (ncons x))))))
(cond ((not (eq (tyi getdefchan) 10)) (zap getdefchan)))
(go l))))
(def getdefact
(lambda (i p exp)
(prog nil
(cond ((or (null getdefprops) (memq p getdefprops))
(terpri)
(print (eval exp))
(princ '" ")
(prin1 p))
(t (terpri)
(print i)
(princ '" ")
(prin1 p)
(princ '" ")
(princ 'bypassed))))))
(dv getdefprops (function value expr fexpr macro))
(dv getdeftable
((defprop lambda (x) (getdefact (cadr x) (cadddr x) x))
(dc lambda
(x)
(cond
((or (null getdefprops) (memq 'comment getdefprops))
(eval x))))
(de lambda (x) (getdefact (cadr x) 'expr x))
(df lambda (x) (getdefact (cadr x) 'fexpr x))
(dm lambda (x) (getdefact (cadr x) 'macro x))
(setq lambda (x) (getdefact (cadr x) 'value x))
(dv lambda (x) (getdefact (cadr x) 'value x))
(def lambda (x) (getdefact (cadr x) 'function x))))
(setq filelst nil) ;; initial values
(setq %changes nil)