Return to cmufile.l CVS log

Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib

Annotation of 43BSD/ucb/lisp/lisplib/cmufile.l, revision 1.1

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.