Return to utils.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / fp

Annotation of 42BSD/ucb/fp/utils.l, revision 1.1

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

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