; FP interpreter/compiler
; Copyright (c) 1982 Scott B. Baden
; Copyright (c) 1982 Regents of the University of California.
; All rights reserved. The Berkeley software License Agreement
; specifies the terms and conditions for redistribution.
(setq SCCS-utils.l "@(#)utils.l 5.1 (Berkeley) 5/31/85")
(declare (localf u$print_fn intName pfn makeroom
getCmdLine) (special cmdLine codePort))
(setq cmdLine (getCmdLine))
(cond ((null cmdLine) (msg N "Illegal Command" N)
(setq command (car cmdLine))
(setq cmdLine (cdr cmdLine))
(let ((cmdFn (get 'cp$ command)))
(cond ((null cmdFn) (msg N "Illegal Command" N))
(t (funcall cmdFn) (return 'cmd$$))))
(do ((names nil) (name$ nil)
(nreverse (cons (implode (nreverse name$)) names)))
(cond ((memq c #.blankOrTab)
(setq names (cons (implode (nreverse name$)) names))
(t (setq name$ (cons (Tyi) name$))))))
((null (setq infile (car (errset (infile (concat h '.fp)) nil))))
((null (setq infile (car (errset (infile h) nil))))
(msg N "Can't open file" N)))))))
(t (msg N "must supply a file" N))))
(setq codePort (car (errset (outfile (car cmdLine)) nil)))
(msg N "Can't open file" N)
(msg (P codePort) "(declare (special DynTraceFlg level))" N)
(do ((l (plist 'sources) (cddr l)))
((null l) (msg (P codePort) N) (close codePort))
(apply 'pp (list '(P codePort) (concat (car l) '_fp)))
"(eval-when (load) (putprop 'sources '"
(msg "must supply a file" N)))
(setq codePort (car (errset (outfile (car cmdLine)) nil)))
(msg N "Can't open file" N)
(msg (P codePort) "(declare (special DynTraceFlg level))" N)
(do ((l (plist 'sources) (cddr l)))
((null l) (msg (P codePort) N) (close codePort))
(let ((fName (concat (car l) '_fp)))
N "(def " fName N (getd `,fName) ")" N))
"(eval-when (load) (putprop 'sources '"
(msg "must supply a file" N)))
(let ((codeFile (car cmdLine)))
else (If (probef (concat codeFile ".o"))
then (load (concat codeFile ".o"))
else (msg N codeFile ": No such File" N))))
else (msg "must supply a file" N)))
(let ((z (plist 'sources)))
(setq ls (cons (car l) ls)))
(trFns (mapcar 'extName TracedFns)))
((null slist) (terpri) (terpri))
(cond ((memq fnName trFns) (setq fnName (concat
(let ((nl (makeroom 80 fnName)))
(let ((vv (- 13 (mod (- (nwritn)
(cond (nl 0) (t oldn))) 12))))
(cond ((lessp 80 (+ (nwritn) vv)) (terpri))
'(lambda (nil) (tyo #.BLANK)) (iota$fp vv))))))))))))
(mapcar '(lambda (u) (terpri) (u$print_fn u) (terpri)) cmdLine))
(defun u$print_fn (fn_name)
(setq source (get 'sources fn_name))
(cond ((null source) (msg fn_name " is not defined"))
(t (mapcar 'p_strng (reverse source))))
(cond ((null (setq outfile (car (errset (outfile (car cmdLine)) nil))))
(msg N "Can't open file" N))
(t (let ((poport outfile))
(do ((l (plist 'sources) (cddr l)))
((null l) (terpri) (terpri))
(mapcar 'p_strng (reverse (cadr l)))
(t (msg N "You must supply a file" N))))
; This is called by delete and function definition
; in case the function to be deleted is being traced.
; It handles the traced-expr property hassles.
(let* ((fnName (concat name '_fp))
(tmp (get fnName 'traced-expr)))
; Do nothing if fn isn't being traced
(t (remprop fnName 'traced-expr)
(setq TracedFns (remove fnName TracedFns))))))
(cond ((null (get 'sources fn)) (msg fn ": No such fn" N))
(cond ((eq d 'on) (setq timeIt t)
(msg N "Timing applications turned on" N))
((eq d 'off) (setq timeIt nil)
(msg N "Timing applications turned off" N))
(t (msg N "Bad Timing Mode" N)))
(let ((cmd (get 'scriptCmd (car cmdLine))))
(cond (cmd (funcall cmd))
(t (msg N "Bad Script Mode" N)))
(defun (scriptCmd open) nil
(let ((nScriptName (cadr cmdLine)))
(cond ((null nScriptName) (msg N "No Script-file specified" N))
(let ((Nptport (outfile nScriptName)))
(cond ((null Nptport) (msg N "Can't open Script-file" N))
(t (msg N "Opening Script File" N)
(and ptport (close ptport))
(setq ptport Nptport))))))))
(defun (scriptCmd append) nil
(let ((nScriptName (cadr cmdLine)))
(cond (ptport (patom nScriptName ptport)))
(let ((Nptport (outfile nScriptName 'append)))
(cond ((null Nptport) (msg N "Can't open Script-file" N))
(t (msg N "Appending to Script File" N)
(and ptport (close ptport))
(setq ptport Nptport))))))
(defun (scriptCmd close) nil
(msg N "Closing Script File" N))
((z (plist 'helpCmd) (cddr z)))
(let ((statOption (get 'statFn (car cmdLine))))
(setq cmdLine (cdr cmdLine))
(cond (statOption (funcall statOption))
(msg N "Bad Stats Option" N)
(msg N "Stats collection turned on" N)
(cond ((null DynTraceFlg)
(setq DynTraceFlg t) ; initialize DynTraceFlg
(setq TracedFns nil)) ; initialize TracedFns
(msg N "Dynamics statistic collection in progress" N)
(msg N "Stats collection turned off" N)
(defun (statFn reset) nil
(msg N "Clearing stats" N)
(defun (statFn print) nil
(PrintMeasures (car cmdLine)))
(cond ((eq d 'on) (setq debug t)
(msg N "Debug flag Set" N ))
((eq d 'off) (setq debug nil)
(msg N "Debug flag Reset" N))
(t (msg N "Bad Debug Mode" N)))
(let ((mode (car cmdLine)))
(setq cmdLine (cdr cmdLine))
(cond ((eq mode 'on) (Trace (mapcar 'intName cmdLine)))
((eq mode 'off) (Untrace (mapcar 'intName cmdLine)))
(t (msg N "Bad Trace Mode" N)))))
; function so see if there's enought room on the line to print
; out some information. If not then start on a new line, too
; bad if the info is longer than one line.
(defun makeroom (rMargin name)
(cond ((greaterp (+ (flatc name 0) (nwritn)) rMargin) (msg N) t)