+;;; 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)
projects / unix-history / commitdiff