![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to cmufile.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 cmufile.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 1: ;;; cmu file package.
2: ;;;
3: (setq rcs-cmufile-
4: "$Header: /usr/lib/lisp/cmufile.l,v 1.1 83/01/29 18:34:10 jkf Exp $")
5:
6: (eval-when (compile eval)
7: (load 'cmumacs)
8: (load 'cmufncs)
9: )
10:
11: (declare (special $cur$ dc-switch piport %indent dc-switch
12: vars body form var init label part incr limit
13: getdeftable $outport$ tlmacros f tmp))
14:
15: (declare (nlambda msg))
16:
17: (declare
18: (special %changes
19: def-comment
20: filelst
21: found
22: getdefchan
23: getdefprops
24: history
25: historylength
26: args
27: i
28: l
29: lasthelp
30: prop
31: special
32: special
33: tlbuffer
34: z))
35:
36: (dv dc-switch dc-define)
37:
38: (dv %indent 0)
39:
40: (dv *digits ("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
41:
42: (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))
43:
44: (def changes
45: (lambda nil
46: (changes1)
47: (for-each f
48: filelst
49: (cond
50: ((get f 'changes)
51: (terpri)
52: (princ f)
53: (tab 15)
54: (princ (get f 'changes)))))
55: (cond
56: (%changes (terpri) (princ '<no-file>) (tab 15) (princ %changes)))
57: nil))
58:
59: (def changes1
60: (lambda nil
61: (cond ((null %changes) nil)
62: (t
63: (prog (found prop)
64: (for-each f
65: filelst
66: (setq found
67: (cons (set-of fn
68: (cons (concat f 'fns)
69: (eval
70: (concat f
71: 'fns)))
72: (memq fn %changes))
73: found))
74: (setq prop (get f 'changes))
75: (for-each fn
76: (car found)
77: (setq prop (insert fn prop nil t)))
78: (putprop f prop 'changes))
79: (setq found (apply 'append found))
80: (setq %changes (set-of fn %changes (not (memq fn found)))))))))
81:
82: (def dc
83: (nlambda (args)
84: (eval (cons dc-switch args]
85:
86: (def dc-define
87: (nlambda (args)
88: (msg "Enter comment followed by <esc>" (N 1))
89: (drain piport)
90: (eval (cons 'dc-dskin args]
91:
92: (def dc-help
93: (nlambda (args)
94: (cond
95: ((eval (cons 'helpfilter (cons (car args) (caddr args))))
96: (transprint getdefchan)))))
97:
98: (def dskin
99: (nlambda (files)
100: (mapc (function
101: (lambda (f)
102: (prog nil
103: (setq dc-switch 'dc-dskin)
104: (file f)
105: (load f)
106: (changes1)
107: (putprop f nil 'changes)
108: (setq dc-switch 'dc-define)
109: )))
110: files]
111:
112: (***
113: The new version of dskout (7/26/80) tries to keep backup versions It returns
114: the setof its arguments that were successfully written If it can not write
115: a file (typically because of protection restrictions) it offers to (try to)
116: write a copy to /tmp A file written to /tmp is not considered to have been
117: successfully written (and changes will not consider it to be up-to-date) )
118:
119: (def dskout
120: (nlambda (files)
121: (changes1)
122: (set-of f
123: files
124: (prog (ffns p tmp)
125: (cond ((atom (errset (setq p (infile f)) nil))
126: (msg "creating " f N D))
127: (t (close p)
128: (cond ((zerop
129: (eval
130: (list 'exec
131: 'mv
132: f
133: (setq tmp
134: (concat f '|.back|)))))
135: (msg "old version moved to "
136: tmp N D))
137: (t (msg
138: "Unable to back up "
139: f
140: " - continue? (y/n) " D)
141: (cond ((not (ttyesno)) (return nil)))))))
142: (cond
143: ((atom
144: (errset (apply (function pp)
145: (cons (list 'F f)
146: (cons (setq ffns
147: (concat f
148: 'fns))
149: (eval ffns))))
150: nil))
151: (msg
152: "Unable to write "
153: f
154: " - try to put it on /tmp? (y/n) " D)
155: (cond
156: ((ttyesno)
157: (setq f (explode f))
158: (while (memq '/ f)
159: (setq f (cdr (memq '/ f))))
160: (setq f
161: (apply (function concat)
162: (cons '/tmp/ f)))
163: (cond ((atom
164: (errset
165: (apply (function pp)
166: (cons (list 'F f)
167: (cons ffns (eval ffns))))))
168: (msg
169: "Unable to create "
170: f
171: " - I give up! " N D ))
172: (t (msg f " written " N D )))))
173: (return nil)))
174: (putprop f nil 'changes)
175: (return t)))))
176:
177: (def dskouts
178: (lambda nil
179: (changes1)
180: (apply (function dskout) (set-of f filelst (get f 'changes)))))
181:
182: (def evl-trace
183: (nlambda (exp)
184: (prog (val)
185: (tab %indent)
186: (prinlev (car exp) 2)
187: ((lambda (%indent) (setq val (eval (car exp)))) (+ 2 %indent))
188: (tab %indent)
189: (prinlev val 2)
190: (return val))))
191:
192:
193: (def file
194: (lambda (name)
195: (setq filelst (insert name filelst nil t))
196: (cond
197: ((not (boundp (concat name 'fns)))
198: (set (concat name 'fns) nil)))
199: name))
200:
201: (def getdef
202: (nlambda (%%l)
203: (prog (x u getdefchan found)
204: (setq getdefchan (infile (car %%l)))
205: l (cond ((atom
206: (setq u
207: (errset
208: (prog (x y z)
209: (cond
210: ((eq (tyipeek getdefchan) -1)
211: (err 'EOF)))
212: (cond
213: ((memq (tyipeek getdefchan)
214: '(12 13))
215: (tyi getdefchan)))
216: (return
217: (cond
218: ((memq (tyipeek getdefchan)
219: '(40 91))
220: (tyi getdefchan)
221: (cond
222: ((and (symbolp
223: (setq y (ratom getdefchan)))
224: (cond (t (comment - what about
225: intern?)
226: (setq x y)
227: t)
228: ((neq y
229: (setq x
230: (intern y)))
231: t)
232: (t (remob1 x) nil))
233: (assoc x getdeftable)
234: (or (setq z (ratom getdefchan))
235: t)
236: (some (cdr %%l)
237: (function
238: (lambda (x)
239: (matchq x z)))
240: nil)
241: (cond ((symbolp z)
242: (setq y z)
243: t)
244: (t (setq y z) t))
245: (cond ((memq y found))
246: ((setq found
247: (cons y found))))
248: (not
249: (cond
250: ((memq (tyipeek
251: getdefchan)
252: '(40 91))
253: (print x)
254: (terpri)
255: (princ y)
256: (tyo 32)
257: (princ
258: '" -- bad format")
259: t))))
260: (cons x
261: (cons y
262: (cond ((memq (tyipeek
263: getdefchan)
264: '(41
265: 93))
266: (tyi
267: getdefchan)
268: nil)
269: (t (untyi 40
270: getdefchan)
271: (read
272: getdefchan))))))))))))))
273: (close getdefchan)
274: (return found))
275: (t (setq x (car u))
276: (*** free u)
277: (setq u nil)
278: (cond
279: ((not (atom x))
280: (apply (cdr (assoc (car x) getdeftable)) (ncons x))))))
281: (cond ((not (eq (tyi getdefchan) 10)) (zap getdefchan)))
282: (go l))))
283:
284: (def getdefact
285: (lambda (i p exp)
286: (prog nil
287: (cond ((or (null getdefprops) (memq p getdefprops))
288: (terpri)
289: (print (eval exp))
290: (princ '" ")
291: (prin1 p))
292: (t (terpri)
293: (print i)
294: (princ '" ")
295: (prin1 p)
296: (princ '" ")
297: (princ 'bypassed))))))
298:
299: (dv getdefprops (function value expr fexpr macro))
300:
301: (dv getdeftable
302: ((defprop lambda (x) (getdefact (cadr x) (cadddr x) x))
303: (dc lambda
304: (x)
305: (cond
306: ((or (null getdefprops) (memq 'comment getdefprops))
307: (eval x))))
308: (de lambda (x) (getdefact (cadr x) 'expr x))
309: (df lambda (x) (getdefact (cadr x) 'fexpr x))
310: (dm lambda (x) (getdefact (cadr x) 'macro x))
311: (setq lambda (x) (getdefact (cadr x) 'value x))
312: (dv lambda (x) (getdefact (cadr x) 'value x))
313: (def lambda (x) (getdefact (cadr x) 'function x))))
314:
315: (setq filelst nil) ;; initial values
316: (setq %changes nil)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.