projects / unix-history / blame
| Commit | Line | Data |
|---|---|---|
| 5ffa1c4c C |
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) |