Return to utils.l CVS log

Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / fp / fp.vax

Annotation of 43BSDTahoe/ucb/fp/fp.vax/utils.l, revision 1.1

1.1     ! root        1: ;  FP interpreter/compiler
        !             2: ;  Copyright (c) 1982  Scott B. Baden
        !             3: ;  Berkeley, California
        !             4: ;
        !             5: ;  Copyright (c) 1982 Regents of the University of California.
        !             6: ;  All rights reserved.  The Berkeley software License Agreement
        !             7: ;  specifies the terms and conditions for redistribution.
        !             8: ;
        !             9: (setq SCCS-utils.l "@(#)utils.l        5.1 (Berkeley) 5/31/85")
        !            10: 
        !            11: ; FP command processor
        !            12: 
        !            13: (include specials.l)
        !            14: (declare (localf u$print_fn intName pfn makeroom
        !            15:                 getCmdLine) (special cmdLine codePort))
        !            16: 
        !            17: (defun get_cmd nil
        !            18:   (prog (cmdLine command)
        !            19:        (setq cmdLine (getCmdLine))
        !            20:        (cond ((null cmdLine) (msg N "Illegal Command" N)
        !            21:               (return 'cmd$$)))
        !            22:        (setq command (car cmdLine))
        !            23:        (setq cmdLine (cdr cmdLine))
        !            24:        (let ((cmdFn (get 'cp$ command)))
        !            25:             (cond ((null cmdFn)  (msg  N "Illegal Command" N))
        !            26:                   (t (funcall cmdFn) (return 'cmd$$))))
        !            27:        (return 'cmd$$)))
        !            28: 
        !            29: (defun getCmdLine nil
        !            30:   (do ((names nil) (name$ nil)
        !            31:        (c (tyipeek) (tyipeek)))
        !            32:       ((eq c #.CR)
        !            33:        (Tyi)
        !            34:        (cond (name$ 
        !            35:              (nreverse (cons (implode (nreverse name$)) names)))
        !            36:             (t (nreverse names))))
        !            37:       (cond ((memq c #.blankOrTab)
        !            38:             (cond (name$
        !            39:                    (setq names (cons (implode (nreverse name$)) names))
        !            40:                    (setq name$ nil)))
        !            41:             (Tyi))
        !            42:            
        !            43:            (t  (setq name$ (cons (Tyi) name$))))))
        !            44: 
        !            45: 
        !            46: (defun (cp$ load) nil
        !            47:   (cond (cmdLine
        !            48:         (let ((h (car cmdLine)))
        !            49:              (cond 
        !            50:               ((null (setq infile (car (errset (infile (concat h '.fp)) nil))))
        !            51:                (cond 
        !            52:                 ((null (setq infile (car  (errset (infile h) nil))))
        !            53:                  (msg N "Can't open file" N)))))))
        !            54:        (t (msg N "must supply a file" N))))
        !            55: 
        !            56: 
        !            57: 
        !            58: (defun (cp$ csave) nil
        !            59:   (If cmdLine then
        !            60:       (setq codePort (car (errset (outfile (car cmdLine)) nil)))
        !            61:       (If (null codePort) then
        !            62:          (msg N "Can't open file" N)
        !            63:          
        !            64:          else
        !            65:          
        !            66:          (msg (P codePort) "(declare (special DynTraceFlg level))" N)
        !            67:          (do ((l (plist 'sources) (cddr l)))
        !            68:              
        !            69:              ((null l) (msg (P codePort) N) (close codePort))
        !            70:              
        !            71:              (apply 'pp (list '(P codePort) (concat (car l) '_fp)))
        !            72:              (msg (P codePort) N)
        !            73:              (msg (P codePort)
        !            74:                   "(eval-when (load) (putprop 'sources '"
        !            75:                                               (cadr l)
        !            76:                                               " '" (car l)
        !            77:                                               "))" N))
        !            78:          )
        !            79:       else
        !            80:       
        !            81:       (msg "must supply a file" N)))
        !            82: 
        !            83: (defun (cp$ fsave) nil
        !            84:   (If cmdLine then
        !            85:       (setq codePort (car (errset (outfile (car cmdLine)) nil)))
        !            86:       (If (null codePort) then
        !            87:          (msg N "Can't open file" N)
        !            88:          
        !            89:          else
        !            90:          
        !            91:          (msg (P codePort) "(declare (special DynTraceFlg level))" N)
        !            92:          (do ((l (plist 'sources) (cddr l)))
        !            93:              
        !            94:              ((null l) (msg (P codePort) N) (close codePort))
        !            95:              
        !            96:              (let ((fName (concat (car l) '_fp)))
        !            97:                   (msg (P codePort)
        !            98:                        N "(def " fName N (getd `,fName) ")" N))
        !            99: 
        !           100:              (msg (P codePort)
        !           101:                   "(eval-when (load) (putprop 'sources '"
        !           102:                                               (cadr l)
        !           103:                                               " '" (car l)
        !           104:                                               "))" N))
        !           105:          )
        !           106:       else
        !           107:       
        !           108:       (msg "must supply a file" N)))
        !           109: 
        !           110: 
        !           111: (defun (cp$ cload) nil
        !           112:   (If cmdLine then 
        !           113:       (let ((codeFile (car cmdLine)))
        !           114:           (If (probef codeFile)
        !           115:               then (load codeFile)
        !           116:               else (If (probef (concat codeFile ".o"))
        !           117:                        then (load (concat codeFile ".o"))
        !           118:                        else (msg N codeFile ": No such File" N))))
        !           119:       else (msg "must supply a file" N)))
        !           120: 
        !           121: 
        !           122: (defun (cp$ fns) nil
        !           123:   (terpri)
        !           124:   (let ((z (plist 'sources)))
        !           125:        (cond ((null z) nil)
        !           126:             (t (do ((slist
        !           127:                      (sort
        !           128:                       (do ((l z (cddr l))
        !           129:                            (ls nil))
        !           130:                           ((null l) ls)
        !           131:                           (setq ls (cons (car l)  ls)))
        !           132:                       'alphalessp)
        !           133:                      (cdr slist))
        !           134: 
        !           135:                     (trFns (mapcar 'extName TracedFns)))
        !           136: 
        !           137:                    ((null slist) (terpri) (terpri))
        !           138: 
        !           139:                    (let ((oldn (nwritn))
        !           140:                          (fnName  (car slist)))
        !           141:                         (cond ((memq fnName trFns) (setq fnName (concat
        !           142:                                                                  fnName
        !           143:                                                                  '@))))
        !           144:                         (let ((nl (makeroom 80 fnName)))
        !           145:                              (patom fnName)
        !           146:                              (let ((vv (- 13 (mod (- (nwritn) 
        !           147:                                                      (cond (nl 0) (t oldn))) 12))))
        !           148:                                   (cond ((lessp 80 (+ (nwritn) vv)) (terpri))
        !           149:                                         (t 
        !           150:                                          (mapcar 
        !           151:                                           '(lambda (nil) (tyo #.BLANK)) (iota$fp vv))))))))))))
        !           152: (defun (cp$ pfn) nil
        !           153:   (mapcar '(lambda (u) (terpri) (u$print_fn u) (terpri)) cmdLine))
        !           154: 
        !           155: (defun  u$print_fn (fn_name)
        !           156:   (let ((source nil))
        !           157:        (setq source (get 'sources fn_name))
        !           158:        (cond ((null source) (msg fn_name  " is not defined"))
        !           159:             (t (mapcar 'p_strng (reverse source))))
        !           160:        (terpri)))
        !           161: 
        !           162: (defun (cp$ save) nil
        !           163:   (cond (cmdLine
        !           164:         (cond ((null (setq outfile (car (errset (outfile (car cmdLine)) nil))))
        !           165:                (msg N "Can't open file" N))
        !           166:               (t (let ((poport outfile))
        !           167:                       (terpri)
        !           168:                       (do ((l (plist 'sources) (cddr l)))
        !           169:                           ((null l) (terpri) (terpri))
        !           170:                           (mapcar 'p_strng (reverse (cadr l)))
        !           171:                           (terpri)
        !           172:                           (terpri)))
        !           173:                  (setq outfile nil))))
        !           174:        (t (msg N "You must supply a file" N))))
        !           175: 
        !           176: ; This is called by delete and function definition
        !           177: ; in case the function to be deleted is being traced.
        !           178: ; It handles the traced-expr property hassles.
        !           179: 
        !           180: (defun untraceDel (name)
        !           181:   (let* ((fnName (concat name '_fp))
        !           182:         (tmp (get fnName 'traced-expr)))
        !           183:        
        !           184:        ; Do nothing if fn isn't being traced
        !           185:        (cond ((null tmp))      
        !           186:              (t (remprop fnName 'traced-expr)
        !           187:                 (setq TracedFns (remove fnName TracedFns))))))
        !           188: 
        !           189: (defun (cp$ delete) nil
        !           190:   (mapcar 'dfn cmdLine))
        !           191: 
        !           192: (defun dfn (fn)
        !           193:   (cond ((null (get 'sources fn)) (msg fn ": No such fn" N))
        !           194:        (t (remprop 'sources fn)
        !           195:           (remob (concat fn '_fp))
        !           196:           (untraceDel fn))))
        !           197: 
        !           198: (defun (cp$ timer) nil
        !           199:   (let ((d (car cmdLine)))
        !           200:        (cond ((eq d 'on) (setq timeIt t) 
        !           201:              (msg N "Timing applications turned on" N))
        !           202:             ((eq d 'off) (setq timeIt nil)
        !           203:              (msg N "Timing applications turned off" N))
        !           204:             (t (msg N "Bad Timing Mode" N)))
        !           205:        (terpri)))
        !           206: 
        !           207: (defun (cp$ script) nil
        !           208:   (let ((cmd (get 'scriptCmd (car cmdLine))))
        !           209:        (cond (cmd (funcall cmd))
        !           210:             (t (msg N "Bad Script Mode" N)))
        !           211:        (terpri)))
        !           212:             
        !           213: 
        !           214: (defun (scriptCmd open) nil
        !           215:   (let ((nScriptName (cadr cmdLine)))
        !           216:        (cond ((null  nScriptName) (msg N "No Script-file specified" N))
        !           217:             (t
        !           218:              (let ((Nptport (outfile nScriptName)))
        !           219:                   (cond ((null Nptport) (msg N "Can't open Script-file" N))
        !           220:                         (t (msg N  "Opening Script File" N)
        !           221:                            (and ptport (close ptport))
        !           222:                            (setq ptport Nptport))))))))
        !           223: 
        !           224: 
        !           225: (defun (scriptCmd append) nil
        !           226:   (let ((nScriptName (cadr cmdLine)))
        !           227:        (cond (ptport (patom nScriptName ptport)))
        !           228:        (let ((Nptport (outfile nScriptName 'append)))
        !           229:            (cond ((null Nptport) (msg N "Can't open Script-file" N))
        !           230:                  (t (msg N "Appending to Script File" N)
        !           231:                     (and ptport (close ptport))
        !           232:                     (setq ptport Nptport))))))
        !           233: 
        !           234: (defun (scriptCmd close) nil
        !           235:   (close ptport)
        !           236:   (setq ptport nil)
        !           237:   (msg N "Closing Script File" N))
        !           238: 
        !           239: (defun (cp$ help) nil
        !           240:   (terpri)
        !           241:   (patom "             Commands are:")
        !           242:   (terpri)
        !           243:   (do
        !           244:    ((z (plist 'helpCmd) (cddr z)))
        !           245:    ((null z)(terpri))
        !           246:    (terpri)
        !           247:    (patom (cadr z))))
        !           248: 
        !           249: 
        !           250: (defun (cp$ stats) nil
        !           251:   (let ((statOption (get 'statFn (car cmdLine))))
        !           252:        (setq cmdLine (cdr cmdLine))
        !           253:        (cond (statOption (funcall statOption))
        !           254:             (t
        !           255:              (msg N "Bad Stats Option" N)
        !           256:              (terpri)))))
        !           257: 
        !           258: (defun (statFn on) nil
        !           259:   (terpri)
        !           260:   (msg N "Stats collection turned on" N)
        !           261:   (terpri)
        !           262:   (terpri)
        !           263:   (startDynStats))
        !           264: 
        !           265: 
        !           266: (defun startDynStats nil
        !           267:   (cond ((null DynTraceFlg)
        !           268:         (setq DynTraceFlg t) ; initialize DynTraceFlg
        !           269:         (setq TracedFns nil)) ; initialize TracedFns
        !           270: 
        !           271:        (t
        !           272:         (terpri)
        !           273:         (msg N "Dynamics statistic collection in progress" N)
        !           274:         (terpri))))
        !           275: 
        !           276: 
        !           277: 
        !           278: (defun (statFn off) nil
        !           279:   (terpri)
        !           280:   (msg N "Stats collection turned off" N)
        !           281:   (terpri)
        !           282:   (terpri)
        !           283:   (stopDynStats))
        !           284: 
        !           285: (defun (statFn reset) nil
        !           286:   (terpri)
        !           287:   (msg N "Clearing stats" N)
        !           288:   (terpri)
        !           289:   (terpri)
        !           290:   (clrDynStats))
        !           291: 
        !           292: (defun (statFn print) nil
        !           293:   (PrintMeasures (car cmdLine)))
        !           294: 
        !           295: (defun (cp$ lisp) nil
        !           296:   (break))
        !           297: 
        !           298: (defun (cp$ debug) nil
        !           299:   (let ((d (car cmdLine)))
        !           300:        (cond ((eq d 'on) (setq debug t) 
        !           301:              (msg N "Debug flag Set" N ))
        !           302:             ((eq d 'off) (setq debug nil)
        !           303:              (msg  N "Debug flag Reset" N))
        !           304:             (t (msg N "Bad Debug Mode" N)))
        !           305:        (terpri)))
        !           306: 
        !           307: (defun (cp$ trace) nil
        !           308:   (let ((mode (car cmdLine)))
        !           309:        (setq cmdLine (cdr cmdLine))
        !           310:        (cond ((eq mode 'on) (Trace (mapcar 'intName cmdLine)))
        !           311:             ((eq mode 'off) (Untrace (mapcar 'intName cmdLine)))
        !           312:             (t (msg N "Bad Trace Mode" N)))))
        !           313: 
        !           314: (defun intName (fName)
        !           315:   (implode
        !           316:    (nreverse
        !           317:     (append 
        !           318:      '(p f _)
        !           319:      (nreverse
        !           320:       (aexplodec fName))))))
        !           321: 
        !           322: 
        !           323: ; function so see if there's enought room on the line to print
        !           324: ; out some information.  If not then start on a new line, too
        !           325: ; bad if the info is longer than one line.
        !           326: 
        !           327: (defun makeroom (rMargin name)
        !           328:   (cond ((greaterp (+ (flatc name 0) (nwritn)) rMargin) (msg N) t)
        !           329:        (t nil)))
        !           330: 

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.