From: CSRG <csrg@ucbvax.Berkeley.EDU>
Date: Mon, 25 Jul 1983 17:36:26 +0000 (-0800)
Subject: BSD 4_2 development
X-Git-Tag: BSD-4_3^2~481
X-Git-Url: https://git.subgeniuskitty.com/unix-history/.git/commitdiff_plain/807afebbb812d25b7c400410b667d4654c99fb09

BSD 4_2 development
Work on file usr/lib/lisp/tpl.l
Work on file usr/src/ucb/lisp/lisplib/fcninfo.l
Work on file usr/lib/lisp/fcninfo.l

Synthesized-from: CSRG/cd1/4.2
---

diff --git a/usr/lib/lisp/fcninfo.l b/usr/lib/lisp/fcninfo.l
new file mode 100644
index 0000000000..15695ac931
--- /dev/null
+++ b/usr/lib/lisp/fcninfo.l
@@ -0,0 +1,92 @@
+(setq rcs-fcninfo-
+   "$Header")
+
+;;
+;; fcninfo.l				-[Sat Jan 29 18:21:45 1983 by jkf]-
+;;
+;; This is normally not loaded into a lisp system but is loaded into
+;; the compiler.  
+;; number of arguments information for C coded functions
+;; not included: evalframe evalhook wait exece
+;; stopped in sysat.c after *invmod
+;
+;; the information is stored in such as way as to minimize the
+;; amount of space required to store the informaion.
+
+
+(eval-when (compile eval)
+   (setq cdescrip " defined in C-coded kernel"))
+
+(defmacro decl-fcn-info (tag fcns)
+   `(let ((fcninfo ',tag))
+       ,@(mapcar '(lambda (fcn) `(putprop ',fcn fcninfo 'fcn-info)) fcns)))
+(defmacro zero (&rest args)
+   `(decl-fcn-info ((0 . 0) ,cdescrip) ,args))	
+(defmacro zero-to-one (&rest args)
+   `(decl-fcn-info ((0 . 1) ,cdescrip) ,args))
+(defmacro zero-to-two (&rest args)
+   `(decl-fcn-info ((0 . 2) ,cdescrip) ,args))
+(defmacro zero-to-inf (&rest args)
+   `(decl-fcn-info (nil ,cdescrip) ,args))
+(defmacro one (&rest args)
+   `(decl-fcn-info ((1 . 1) ,cdescrip) ,args))
+(defmacro one-to-two (&rest args)
+   `(decl-fcn-info ((1 . 2) ,cdescrip) ,args))
+(defmacro one-to-three (&rest args)
+   `(decl-fcn-info ((1 . 3) ,cdescrip) ,args))
+(defmacro one-to-inf (&rest args)
+   `(decl-fcn-info ((1 . nil) ,cdescrip) ,args))
+(defmacro two (&rest args)
+   `(decl-fcn-info ((2 . 2) ,cdescrip) ,args))
+(defmacro two-to-inf (&rest args)
+   `(decl-fcn-info ((1 . nil) ,cdescrip) ,args))
+(defmacro three (&rest args)
+   `(decl-fcn-info ((3 . 3) ,cdescrip) ,args))
+(defmacro three-to-five (&rest args)
+   `(decl-fcn-info ((3 . 5) ,cdescrip) ,args))
+(defmacro three-to-inf (&rest args)
+   `(decl-fcn-info ((3 . nil) ,cdescrip) ,args))
+(defmacro four (&rest args)
+   `(decl-fcn-info ((4 . 4) ,cdescrip) ,args))
+(defmacro five (&rest args)
+   `(decl-fcn-info ((5 . 5) ,cdescrip) ,args))
+
+
+(zero baktrace fork oblist ptime reset resetio zapline)
+(zero-to-one arg close drain dumplisp exit
+   gensym monitor nwritn random return terpr time-string tyipeek)
+(zero-to-two err ratom read readc tyi)
+(zero-to-inf + - * / and concat cond
+   difference greaterp lessp list or plus product prog quotient setq
+   sum times unconcat)
+(one  1+ 1- absval add1
+   aexplode aexplodec aexploden argv
+   arrayp ascii asin acos atom bcdp
+   bignum-to-list boundp car cdr chdir cos
+   dtpr exp fact fake fix float frexp function get_pname getaccess getaux
+   getd getdata getdelta
+   getentry getenv getdisc getlength go haulong infile log 
+   implode intern maknam maknum makunbound minus minusp
+   not ncons null numberp onep plist pntlen portp ptr 
+   quote readlist remob *rset sin sizeof stringp sub1 sqrt symbolp
+   truename type valuep zerop)
+(one-to-two errset flatc outfile patom print status tyo untyi)
+(one-to-three fasl load process)
+(one-to-inf funcall progv)
+(two  allocate alphalessp
+   arrayref assq atan bignum-leftshift *catch cons
+   Divide eq equal freturn
+   get haipart *invmod lsh
+   mfunction mod *mod nthelem putaux putd
+   putdata putdelta putdisc putlength
+   remprop replace rot rplaca rplacd segment set setarg setplist scons
+   signal sstatus sticky-bignum-leftshift *throw
+   vref vrefi-byte vrefi-word vrefi-long)
+   
+(two-to-inf  apply def mapc mapcan mapcar mapcon maplist prog2)
+(three putprop)
+(three-to-five cfasl)
+(three-to-inf boole)
+(four Emuldiv)
+(five marray)
+
diff --git a/usr/lib/lisp/tpl.l b/usr/lib/lisp/tpl.l
new file mode 100644
index 0000000000..bc0e725a93
--- /dev/null
+++ b/usr/lib/lisp/tpl.l
@@ -0,0 +1,751 @@
+(setq rcs-tpl-
+   "$Header: /usr/lib/lisp/RCS/tpl.l,v 1.3 83/04/09 12:58:51 jkf Exp $")
+
+;				-[Tue Apr  5 12:32:38 1983 by jkf]-
+;
+
+; to do
+; ?state : display  status translink, *rset, displace-macros.
+;		current error, prinlevel and prinlength
+;	   add a way of modifying the values
+; ?bk [n] : do a baktrace (default 10 frames from bottom)
+; ?zo [n] : add an optional number of frames to zoom
+; ?retf : return value from 'current' frame
+; ?retry : retry expr in 'current' frame (required mod to lisp).
+;
+; the frame re-eval question is not asked when it should.
+; interact with tracebreaks correctly
+;
+; add stepper.
+; get 'debugging' to work ok.
+
+;--- state
+;
+(declare (special tpl-debug-on tpl-step-on
+		  tpl-top-framelist tpl-bot-framelist
+		  tpl-eval-flush tpl-trace-flush
+		  tpl-prinlength tpl-prinlevel
+		  prinlevel prinlength
+		  tpl-commands tpl-break-level
+		  tpl-spec-char
+		  tpl-last-loaded
+		  tpl-level
+		  tpl-fcn-in-eval
+		  tpl-contuab
+		  ER%tpl ER%all given-history res-history
+		  tpl-stack-bad tpl-stack-ok
+		  tpl-history-count
+		  tpl-history-show
+		  tpl-dontshow-tpl
+		  *rset % piport
+		  debug-error-handler
+		  ))
+
+(putd 'tpl-eval (getd 'eval))
+(putd 'tpl-funcall (getd 'funcall))
+
+;--- macros which should be in the system
+;
+(defmacro evalframe-type (evf) `(car ,evf))
+(defmacro evalframe-pdl (evf)  `(cadr ,evf))
+(defmacro evalframe-expr (evf) `(caddr ,evf))
+(defmacro evalframe-bind (evf) `(cadddr ,evf))
+(defmacro evalframe-np (evf)   `(caddddr ,evf))
+(defmacro evalframe-lbot (evf) `(cadddddr ,evf))
+
+
+;; messages are passed between break levels by means of catch and
+;; throw:
+(defmacro tpl-throw (value) `(*throw 'tpl-break-catch ,value))
+(defmacro tpl-catch (form) `(*catch 'tpl-break-catch ,form))
+
+; A tpl-catch is placed around the prompting and evaluation of forms.
+; if something abnormal happens in the evaluation, a tpl-throw is done
+; which then tells the break look that something special should be
+; done.
+;
+; messages:
+;   contbreak  -  this tells the break level to print out the message
+;		  it prints when it is entered (such as the error message).
+;		  [see poplevel message]. 
+;   poplevel   -  tells the break level to jump up to the next higher
+;		  break level and continue there.  It sends  contbreak
+;		  message to that break level so that it will remind the
+;		  user what the state is. [see cmd: ?pop ]
+;   reset      -  This tells the break level to send a reset to the next
+;		  higher break level.  Thus a reset is done by successive
+;		  small pops.  This isn't totally necessary, but it is
+;		  clean.
+;  (retbreak v) - return from the break level, returning the value v.
+;		  If this an error break, then we return (list v) since
+;		  that is required to indicate that an error has been
+;		  handled.
+;  (retry v)	- instead of asking for a new value, retry the given one.
+;  popretry     - take the expression that caused the current break and
+;		  send a (retry expr) message to the break level above us
+;		  so that it can be tried again.
+
+(setq tpl-eval-flush nil  tpl-trace-flush nil
+   tpl-prinlevel 3 tpl-prinlength 4
+   tpl-spec-char #/?)
+
+(or (boundp 'tpl-last-loaded) (setq tpl-last-loaded nil))
+
+(defun tpl nil
+   (let ((debug-error-handler 'tpl-err-all-fcn))
+      (setq ER%tpl 'tpl-err-tpl-fcn)
+      (putd '*break (getd 'tpl-*break))
+      (setq given-history nil
+	    res-history   nil
+	    tpl-debug-on  nil
+	    tpl-step-on   nil
+	    tpl-top-framelist nil
+	    tpl-bot-framelist nil
+	    tpl-stack-bad t
+	    tpl-stack-ok nil
+	    tpl-fcn-in-eval nil
+	    tpl-level nil
+	    tpl-history-count 0
+	    tpl-break-level -1
+	    tpl-dontshow-tpl t
+	    tpl-history-show 10)
+      (do ((retv))
+	  (nil)
+	  (setq retv
+		(tpl-catch
+		   (tpl-break-function nil))))))
+
+
+;--- do-one-transaction
+;  do a single read-eval-print transaction
+;  If eof-form is given, then we provide a prompt and read the input,
+;   otherwise given is what we use, but we print the prompt and the
+;   given input before evaling it again.
+; (given must be in the form (sys|user ..)
+;
+(defun do-one-transaction (given prompt eof-form)
+   (let (retv)
+      (patom prompt)
+      (If eof-form
+	 then (setq given
+		    (car (errset (ntpl-read nil eof-form))))
+	      (If (eq eof-form given)
+		 then (If (status isatty)
+			 then (msg "EOF" N)
+			      (setq given '(sys  <eof>))
+			 else (exit)))
+	 else (tpl-history-form-print given)
+	      (terpr))
+      (add-to-given-history given)
+      (If (eq 'user (car given))
+	 then (setq tpl-stack-bad t)
+	      (setq retv (tpl-eval (cdr given)))
+	      (setq tpl-stack-bad t)
+	 else (setq retv (process-fcn (cdr given)))
+	      (setq tpl-stack-bad (not tpl-stack-ok)))
+      (add-to-res-history retv)
+      (ntpl-print retv)
+      (terpr)
+      ))
+		     
+
+;; reader
+; if sees a rpar as the first non space char, it just reads all chars
+; return (sys . form)  where form is a list, e.g
+;			)foo bar baz rets (sys foo bar baz)
+;  or
+;  (user . form)
+; note: if nothing is typed, (sys) is returned
+;
+(defun ntpl-read (port eof-form)
+   (let (ch)
+      ; skip all spaces
+      (do ()
+	  ((and (not (eq (setq ch (tyipeek port)) #\space))
+		(not (eq ch #\newline))))
+	  (setq ch (tyi)))
+      (If (eq ch #\eof)
+	 then eof-form
+	 else (setq ch (tyi port))
+	      (If (eq ch tpl-spec-char)
+		 then (do ((xx (list #\lpar) (cons (tyi) xx)))
+			  ((or (eq #\eof (car xx))
+			       (eq #\newline  (car xx)))
+			   (cons 'sys
+				 (car (errset
+					 (readlist
+					    (nreverse
+					       (cons #\rpar (cdr xx)))))))))
+		 else (untyi ch)
+		      (cons 'user (read port eof-form))))))
+
+;--- tpl-history-form-print :: the inverse of tpl-read
+; this takes the history form of an expression and prints it out
+; just as the user would have typed it.
+;
+(defun tpl-history-form-print (form)
+   (If (eq 'user (car form))
+      then (print (cdr form))
+      else (patom "?")
+	   (mapc '(lambda (x) (print x) (patom " ")) (cdr form))))
+
+(defun ntpl-print (form)
+   (print form))
+
+(setq tpl-commands
+   '( ((help h) tpl-command-help
+       " [cmd] - print general or specific info "
+       " '?help' - print a short description of all commands "
+       " '?help cmd' - print extended information on the given command ")
+      ( ? tpl-command-redo
+	" [args] - redo last or previous command "
+	" '??' - redo last user command "
+	" '?? n' - (for n>0) redo command #n (as printed by ?history)"
+	" '?? -n' - (for n>0) redo n'th previous command (?? -1 == ??)"
+	" '?? symb' - redo last with car == symb"
+	" '?? symb *' - redo last with car == symb*")
+      ( (his history) tpl-command-history
+	" [r] - print history list "
+	" ?history, ?his - print list of commands previously executed"
+	" '?his r' - print results too")
+      ( (re reset) tpl-command-reset
+	" - pop up to the top level"
+	" '?re, ?reset', pop up to the top level ")
+      ( tr tpl-command-trace
+	" [fn ..] - trace"
+	" '?tr' - print list of traced functions"
+	" '?tr fn ...' - trace given functions, can be fn or (fn cmd ...)"
+	"	where cmds are trace commands")
+      ( state tpl-command-state
+	" [vals] - print or change state "
+	" 'state' - print current state in short form "
+	" 'state l' - print state in long form"
+	" 'state sym val ... ...' - set values of state "
+	"	symbols are those given in 'state  l' list")
+      ( prt tpl-command-prt
+	" - pop up a level and retry the command which caused this break"
+	" ?prt - do a ?pop followed by a retry of the command which"
+	"	caused this break to be entered")
+      ( ld  tpl-command-load
+	" [file ...] - load given or last files"
+	" 'ld'  - loads the last files loaded with ?ld"
+	" 'ld file ...' - loads the given files")
+      ( debug tpl-command-debug
+	" [off] - toggle debug state "
+	" 'debug' Turns on debugging.  When debug is on then"
+	"	enough information is kept around for viewing"
+	"	and quering evaluation stack"
+	" 'debug off' - Turns off debuging" )
+      ( pop tpl-command-pop
+	" - pop up to previous break level"
+	" 'pop' - if not at top level, pop up to the break level"
+	"	above this one")
+      ( ret tpl-command-ret
+	" [val] - return value from this break loop "
+	" 'ret [val]' if this is a break look due to a break command "
+	"	or a continuable error, evaluate val (default nil)"
+	"	and return it to the function that found an error,"
+	" 	allowing it to continue")
+      
+      ( zo tpl-command-zoom
+	" - view a portion of evaluation stack"
+	" 'zo' - show a portion above and below the 'current' stack"
+	"	frame.  Use )up and )dn or alter current stack frame")
+      ( dn tpl-command-down
+	" [n] - go down stack frames "
+	" 'dn' - move the current stack frame down one.  Down refers to"
+	"	older stack frames"
+	" 'dn n' - n is a fixnum telling how many stack frames to go down"
+	" 'dn n z' - after going down, do a zoom"
+	" After dn is done, a limited zoom will be done")
+      ( up tpl-command-up
+	" [n] - go up stack frames "
+	" 'up' - move the current stack frame up one.  Up refers to"
+	"	younger stack frames"
+	" 'up n' - n is a fixnum telling how many stack frames to go up")
+      ( ev tpl-command-ev
+	" symbol - eval the given symbol wrt the current frame "
+	" 'ev symbol' - determine the value of the given symbol"
+	"	after restoring the bindings to the way they were"
+	"	when the current frame was current.  see ?zo,?up,?dn")
+      ( pp tpl-command-pp
+	" - pretty print the current frame "
+	" 'pp' - pretty print the current frame (see ?zo, ?up, ?dn)")
+      ( <eof> tpl-command-pop
+	" - pop one break level up "
+	" '^D' - if connect to tty, pops up one break level,"
+	"        otherwise, exits doesn't exit unless  "))
+   )
+	       
+;--- process-fcn :: do a user command
+;
+(defun process-fcn (form)
+   (let ((sel (car form)))
+      (setq tpl-stack-ok nil)
+      (do ((xx tpl-commands (cdr xx))
+	   (this))
+	  ((null xx)
+	   (msg "Illegal command, type )help for list of commands" N))
+	  (If (or (and (symbolp (setq this (caar xx)))
+		       (eq sel this))
+		  (and (dtpr this)
+		       (memq sel this)))
+	      then (return (tpl-funcall (cadar xx) form))))))
+			    
+	      
+   
+;--- tpl commands
+;
+
+;--- tpl-command-help
+(defun tpl-command-help (x)
+   (setq tpl-stack-ok t)
+   (If (cdr x)
+      then (do ((xx tpl-commands (cdr xx))
+		(sel (cadr x))
+		(this))
+	       ((null xx)
+		(msg "I don't know that command" N))
+	       ; look for command in tpl-commands list
+	       (If (or (and (symbolp (setq this (caar xx)))
+		       (eq sel this))
+		  (and (dtpr this)
+		       (memq sel this)))
+		  then (return (do ((yy (cdddar xx) (cdr yy)))
+				   ((null yy))
+				   ; print all extended documentation
+				   (patom (car yy))
+				   (terpr)))))
+      else ; print short info on all commands
+	   (mapc #'(lambda (x)
+		      (let ((sel (car x)))
+			 ; first print selector or selectors
+			 (If (dtpr sel)
+			    then (patom (car sel))
+				 (mapc #'(lambda (y) (patom ",") (patom y))
+					(cdr sel))
+			    else (patom sel))
+			 ; next print documentation
+			 (patom (caddr x))
+			 (terpr)))
+		  tpl-commands))
+   nil)
+
+(defun tpl-command-load (args)
+   (setq args (cdr args))
+   (If args
+      then (setq tpl-last-loaded args)
+	   (mapc 'load args)
+    elseif tpl-last-loaded
+      then (mapc 'load tpl-last-loaded)
+      else (msg "Nothing to load" N)))
+
+	      
+(defun tpl-command-trace (args)
+   (setq args (cdr args))
+   (apply 'trace args))
+
+	 
+   
+;--- tpl-command-state
+;
+(defun tpl-command-state (x)
+   (msg " State:  debug " tpl-debug-on ", step " tpl-step-on N))
+
+;--- tpl-command-debug
+;
+(defun tpl-command-debug (x)
+   (If (memq 'off (cdr x))
+      then (*rset nil)
+	   (msg "Debug is off" N)
+	   (setq tpl-debug-on nil)
+      else (*rset t)
+	   (sstatus translink nil)
+	   (msg "Debug is on" N)
+	   (setq tpl-debug-on t)))
+
+;--- tpl-command-zoom
+;
+(defun tpl-command-zoom (x)
+   (tpl-update-stack)
+   (setq tpl-stack-ok t)
+   (tpl-zoom))
+
+;--- tpl-command-down
+;
+(defun tpl-command-down (args)
+   (setq tpl-stack-ok t)
+   (let ((count 1))
+      (If (and (fixp (cadr args)) (> (cadr args) 0))
+	 then (setq count (cadr args)))
+      (do ((xx count (1- xx)))
+	  ((= 0 xx))
+	  (If tpl-bot-framelist
+	     then (setq tpl-top-framelist (cons (car tpl-bot-framelist)
+						tpl-top-framelist)
+			tpl-bot-framelist (cdr tpl-bot-framelist))))
+      (If (memq 'z (cdr args))
+	  then (tpl-command-zoom nil))))
+
+;--- tpl-command-up :: move up in the current stack
+; moves from top to bot stacks
+;
+(defun tpl-command-up (args)
+   (setq tpl-stack-ok t)
+   (let ((count 1))
+      (If (and (fixp (cadr args)) (> (cadr args) 0))
+	 then (setq count (cadr args)))
+      (do ((xx count (1- xx)))
+	  ((= 0 xx))
+	  (If tpl-top-framelist
+	     then (setq tpl-bot-framelist (cons (car tpl-top-framelist)
+						tpl-bot-framelist)
+			tpl-top-framelist (cdr tpl-top-framelist))))))
+
+(defun tpl-command-ev (args)
+   (let ((sym (cadr args)))
+      (If (not (symbolp sym))
+	 then (msg "ev must be given a symbol" N)
+       elseif (null tpl-bot-framelist)
+	 then (msg "there is no evaluation stack, is debug on?")
+	 else (prog1 (eval sym (evalframe-bind (car tpl-bot-framelist)))
+		     (setq tpl-stack-ok t)))))
+
+
+(defun tpl-command-pp (args)
+   (pp-form (evalframe-expr (car tpl-bot-framelist)))
+   (terpr)
+   nil)
+
+;;-- history list maintainers
+;
+; history lists are just lists of forms
+; one for the given, and one for the returned
+;
+(defun most-recent-given () (car given-history))
+
+(defun add-to-given-history (form)
+   (setq given-history (cons form given-history))
+   (setq res-history   (cons nil  res-history))
+   (If (not (eq (car form) 'history))
+       then (setq tpl-history-count (1+ tpl-history-count))))
+
+(defun add-to-res-history (form)
+   (setq res-history (cons form (cdr res-history)))
+   (setq % form))
+
+   
+;--- evalframe generation
+;
+
+(defun tpl-update-stack nil
+   (If tpl-stack-bad
+      then (If (tpl-yorn "Should I re-calc the stack(y/n):")
+	      then (tpl-gentrace)
+	      else (msg "[not re-calc'ed]" N)
+		   (setq tpl-stack-bad nil))))
+
+;--- tpl-gentrace
+; this is called before an function which references the
+; frame list.  it needn't be called unless one knows that
+; the frame status has changed
+;
+(defun tpl-gentrace ()
+   (let ((templist (tpl-getframelist)))
+      ; templist contains the frame from bottom (oldest) to top
+
+      (setq templist (nreverse templist)) ; now youngest to oldest
+
+      
+      ; determine a new framelist and put it on the bottom list
+      ; the top list is empty.  the first thing in the
+      ; bottom framelist is the 'current' frame.
+
+      ; go though frames, based on flags, flush trace calls
+      ; or eval calls
+      (do ((xx templist (cdr xx))
+	   (remember (If tpl-dontshow-tpl then nil else t))
+	   (forget-this nil nil)
+	   (res)
+	   (exp)
+	   (flushpoint))
+	  ((null xx) (setq tpl-bot-framelist (nreverse res)))
+	  (setq exp (evalframe-expr (car xx)))
+	  (If (dtpr exp)
+	     then (If (and tpl-dontshow-tpl
+			   (memq (car exp) '(tpl-eval tpl-funcall)))
+		     then (setq remember nil)))
+	  (If (dtpr exp)
+	     then (If (and tpl-dontshow-tpl (memq (car exp)
+						 '(tpl-err-tpl-fcn)))
+		      then (setq forget-this t)))
+	  (If (and remember (not forget-this))
+	      then (setq res (cons (car xx) res)))
+	  (If (dtpr exp)
+	     then (If (and tpl-dontshow-tpl
+			   (eq (car exp) 'tpl-break-function))
+		     then (setq remember t))))
+
+      (setq tpl-top-framelist nil)))
+
+(defun tpl-getframelist nil
+   (let ((frames)
+	 temp)
+      (If *rset
+	 then ; Getting the first few frames is tricky because
+	      ; the frames disappear quickly.
+	      (setq temp (evalframe nil))	; call to setq
+	      (setq temp (evalframe (evalframe-pdl temp)))
+	      (do ((xx (list (evalframe (evalframe-pdl temp)))
+		       (cons (evalframe (evalframe-pdl (car xx))) xx)))
+		  ((null (car xx))
+		   (cdr xx))))))
+
+	       
+(defun tpl-printframelist (printdown  vals count)
+   (If (null vals)
+      then (If printdown
+	      then (msg "*** bottom ***" N)
+	      else (msg "*** top ***" N))
+    elseif (= 0 count)
+      then (msg "... " (length vals) " more ..." N)
+    else (If (not printdown)
+	    then (tpl-printframelist printdown (cdr vals) (1- count)))
+	 (let ((prinlevel tpl-prinlevel)
+	       (prinlength tpl-prinlength))
+	    (print (evalframe-expr (car vals)))
+	    (terpr))
+	 (If printdown
+	    then (tpl-printframelist printdown (cdr vals) (1- count)))))
+
+
+(defun tpl-zoom nil
+   (tpl-printframelist nil tpl-top-framelist 4)
+   (msg "// current \\\\" N)
+   (tpl-printframelist t   tpl-bot-framelist 4))
+
+		  
+
+(defmacro errdesc-class (err) `(car ,err))
+(defmacro errdesc-id    (err) `(cadr ,err))
+(defmacro errdesc-contp (err) `(caddr ,err))
+(defmacro errdesc-descr (err) `(cdddr ,err))
+
+;--- error handler
+;
+
+(defun tpl-break-function (reason)
+   (do ((tpl-fcn-in-eval (most-recent-given))
+	(tpl-level reason)
+	(tpl-continuab)
+	(tpl-break-level (1+ tpl-break-level))
+	(prompt)
+	(do-retry nil nil)
+	(retry-value)
+	(retv 'contbreak)
+	(piport nil)
+	(eof-form (ncons nil)))
+       (nil)
+       (If (eq retv 'contbreak)
+	  then
+	       (If (memq (car reason) '(error derror))
+		  then (if (eq (car reason) 'error)
+			  then (msg "Error: ")
+			  else (msg "DError: "))
+		       (patom (car (errdesc-descr (cdr reason))))
+		       (mapc #'(lambda (x) (patom " ") (print x))
+			      (cdr (errdesc-descr (cdr reason))))
+		       (terpr)
+		       (msg "Form: " (cdr tpl-fcn-in-eval))
+		elseif (eq 'break (car reason))
+		  then (msg "Break: ")
+		       (patom (cadr reason))
+		       (mapc #'(lambda (x) (patom " ") (print x))
+			      (cddr reason)))
+	       (terpr)
+	       (setq tpl-contuab (or (memq (car reason) '(break derror))
+				     (errdesc-contp (cdr reason))))
+	       (setq prompt (If reason
+			       then (concat (if (eq (car reason) 'derror)
+					       then "d" else "")
+					    (If tpl-contuab then "c" else "")
+					    "{"
+					    tpl-break-level
+					    "} ")
+			       else "=> "))
+	elseif (eq retv 'reset)
+	  then (tpl-throw 'reset)
+	elseif (eq retv 'poplevel)
+	  then (tpl-throw 'contbreak)
+	elseif (eq retv 'popretry)
+	  then (tpl-throw `(retry ,tpl-fcn-in-eval))
+	elseif (dtpr retv)
+	  then (If (eq 'retbreak (car retv))
+		  then (If (eq 'error (car reason))
+			  then (return (cdr retv))	; return from error
+			  else (return (cadr retv)))
+		  else (If (eq 'retry (car retv))
+			  then (setq do-retry t
+				     retry-value (cadr retv)))))
+       (setq retv
+	     (tpl-catch
+		     (do ()
+			 (nil)
+			 (If (null do-retry)
+			    then (do-one-transaction nil prompt eof-form)
+			    else (do-one-transaction retry-value prompt nil))
+			 (setq do-retry nil)
+			 nil)))))
+
+;--- tpl-err-tpl-fcn
+; attached to ER%tpl, the error will return to top level
+; generic error handler
+;
+(defun tpl-err-tpl-fcn (err)
+   (tpl-break-function (cons 'error err)))
+
+;--- tpl-err-all-fcn
+; attached to ER%all if (debugging t) is done.
+;
+(defun tpl-err-all-fcn (err)
+   (setq ER%all 'tpl-err-all-fcn)
+   (tpl-break-function (cons 'derror err)))
+   
+;-- tpl-command-pop
+; pop a break level
+; 
+(defun tpl-command-pop (x)
+   (If (= 0 tpl-break-level)
+      then (msg "Already at top level " N)
+      else (tpl-throw 'poplevel)))
+
+       
+	   
+(defun tpl-command-ret (x)
+   (If tpl-contuab
+      then (tpl-throw (list 'retbreak (eval (cadr x))))
+      else (msg "Can't return at this point" N)))
+
+;--- tpl-command-redo
+; see documentatio above for a list of the various things this accepts
+;
+(defun tpl-command-redo (x)
+   (setq x (cdr x))
+   (If (null x)
+      then (tpl-redo-by-count 1)
+    elseif (fixp (car x))
+      then (If (< (car x) 0)
+	      then (tpl-redo-by-count (- (car x)))
+	      else (If (not (< (car x) tpl-history-count))
+		      then (msg "There aren't that many commands " N)
+		      else (tpl-redo-by-count (- tpl-history-count (car x)))))
+      else (tpl-redo-by-car x)))
+
+
+;--- tpl-redo-by-car :: locate command to do by the car of the command
+;
+(defun tpl-redo-by-car (x)
+   (let ((command (car x))
+	 (substringp (If (eq (cadr x) '*) thenret)))
+      (If substringp
+	 then (If (not (symbolp command))
+		 then (msg "must give a symbol before *" N)
+		 else (let* ((string (get_pname command))
+			     (len (pntlen string)))
+			 (do ((xx (tpl-next-user-in-history given-history)
+				  (tpl-next-user-in-history (cdr xx)))
+			      (pos))
+			     ((null xx)
+			      (msg "Can't find a match" N))
+			     (If (and (dtpr (cdar xx))
+				      (symbolp (setq pos (cadar xx))))
+				then (If (equal (substring pos 1 len)
+						string)
+					then (tpl-throw
+						     `(retry ,(car xx))))))))
+	 else (do ((xx (tpl-next-user-in-history given-history)
+		       (tpl-next-user-in-history (cdr xx)))
+		   (pos))
+		  ((null xx)
+		   (msg "Can't find a match" N))
+		  (If (and (dtpr (cdar xx))
+			   (symbolp (setq pos (cadar xx))))
+		     then (If (eq pos command)
+			     then (tpl-throw
+					  `(retry ,(car xx)))))))))
+			     
+;--- tpl-redo-by-count :: redo n'th previous input
+; n>=0.  if n=0, then redo last.
+;
+(defun tpl-redo-by-count (n)
+   (do ((xx  n (1- xx))
+	(list (tpl-next-user-in-history given-history)
+	      (tpl-next-user-in-history (cdr list))))
+       ((or (not (> xx 0)) (null list))
+	(If (null list)
+	   then (msg "There aren't that many commands " N)
+	   else (tpl-throw `(retry ,(car list)))))))
+
+
+'(defun tpl-next-user-in-history (hlist)
+   (do ((histlist hlist (cdr histlist)))
+       ((or (null histlist)
+	    (eq 'user (caar histlist)))
+	histlist)))
+
+(defun tpl-next-user-in-history (hlist)
+   hlist)
+
+;--- tpl-command-prt
+; pop and retry command which failed this time
+;
+(defun tpl-command-prt (x)
+   (tpl-throw 'popretry))
+
+
+;--- tpl-command-history
+;
+(defun tpl-command-history (x)
+   (let (show-res)
+      (If (memq 'r (cdr x))
+	 then (setq show-res t))
+      (tpl-command-his-rec tpl-history-show tpl-history-count show-res
+			   given-history res-history)))
+
+(defun tpl-command-his-rec (count current show-res hlist rhlist)
+   (If (and hlist (> count 0))
+      then (tpl-command-his-rec (1- count) (1- current) show-res
+				(cdr hlist) (cdr rhlist)))
+   (If hlist
+      then
+	   (let ((prinlevel tpl-prinlevel)
+		 (prinlength tpl-prinlength))
+	      (msg current ": ") (tpl-history-form-print (car hlist))
+	      (terpr)
+	      (If show-res
+		 then (msg "% " current ": " (car rhlist) N)))))
+
+
+(defun tpl-command-reset (x)
+   (tpl-throw 'reset))
+
+(defun tpl-yorn (message)
+   (drain piport)
+   (msg message)
+   (let ((ch (tyi)))
+      (drain piport)
+      (eq #/y ch)))
+
+       
+;--- tpl-*break :: handle breaks
+;  when tpl starts, this is put on *break's function cell
+;
+(defun tpl-*break (pred message)
+   (let ((^w nil))
+      (cond (pred (tpl-break-function (list 'break message))))))
+
+
+; in order to use this: (setq user-top-level 'tpl)
+
+	   
+(putprop 'tpl t 'version)
diff --git a/usr/src/ucb/lisp/lisplib/fcninfo.l b/usr/src/ucb/lisp/lisplib/fcninfo.l
new file mode 100644
index 0000000000..15695ac931
--- /dev/null
+++ b/usr/src/ucb/lisp/lisplib/fcninfo.l
@@ -0,0 +1,92 @@
+(setq rcs-fcninfo-
+   "$Header")
+
+;;
+;; fcninfo.l				-[Sat Jan 29 18:21:45 1983 by jkf]-
+;;
+;; This is normally not loaded into a lisp system but is loaded into
+;; the compiler.  
+;; number of arguments information for C coded functions
+;; not included: evalframe evalhook wait exece
+;; stopped in sysat.c after *invmod
+;
+;; the information is stored in such as way as to minimize the
+;; amount of space required to store the informaion.
+
+
+(eval-when (compile eval)
+   (setq cdescrip " defined in C-coded kernel"))
+
+(defmacro decl-fcn-info (tag fcns)
+   `(let ((fcninfo ',tag))
+       ,@(mapcar '(lambda (fcn) `(putprop ',fcn fcninfo 'fcn-info)) fcns)))
+(defmacro zero (&rest args)
+   `(decl-fcn-info ((0 . 0) ,cdescrip) ,args))	
+(defmacro zero-to-one (&rest args)
+   `(decl-fcn-info ((0 . 1) ,cdescrip) ,args))
+(defmacro zero-to-two (&rest args)
+   `(decl-fcn-info ((0 . 2) ,cdescrip) ,args))
+(defmacro zero-to-inf (&rest args)
+   `(decl-fcn-info (nil ,cdescrip) ,args))
+(defmacro one (&rest args)
+   `(decl-fcn-info ((1 . 1) ,cdescrip) ,args))
+(defmacro one-to-two (&rest args)
+   `(decl-fcn-info ((1 . 2) ,cdescrip) ,args))
+(defmacro one-to-three (&rest args)
+   `(decl-fcn-info ((1 . 3) ,cdescrip) ,args))
+(defmacro one-to-inf (&rest args)
+   `(decl-fcn-info ((1 . nil) ,cdescrip) ,args))
+(defmacro two (&rest args)
+   `(decl-fcn-info ((2 . 2) ,cdescrip) ,args))
+(defmacro two-to-inf (&rest args)
+   `(decl-fcn-info ((1 . nil) ,cdescrip) ,args))
+(defmacro three (&rest args)
+   `(decl-fcn-info ((3 . 3) ,cdescrip) ,args))
+(defmacro three-to-five (&rest args)
+   `(decl-fcn-info ((3 . 5) ,cdescrip) ,args))
+(defmacro three-to-inf (&rest args)
+   `(decl-fcn-info ((3 . nil) ,cdescrip) ,args))
+(defmacro four (&rest args)
+   `(decl-fcn-info ((4 . 4) ,cdescrip) ,args))
+(defmacro five (&rest args)
+   `(decl-fcn-info ((5 . 5) ,cdescrip) ,args))
+
+
+(zero baktrace fork oblist ptime reset resetio zapline)
+(zero-to-one arg close drain dumplisp exit
+   gensym monitor nwritn random return terpr time-string tyipeek)
+(zero-to-two err ratom read readc tyi)
+(zero-to-inf + - * / and concat cond
+   difference greaterp lessp list or plus product prog quotient setq
+   sum times unconcat)
+(one  1+ 1- absval add1
+   aexplode aexplodec aexploden argv
+   arrayp ascii asin acos atom bcdp
+   bignum-to-list boundp car cdr chdir cos
+   dtpr exp fact fake fix float frexp function get_pname getaccess getaux
+   getd getdata getdelta
+   getentry getenv getdisc getlength go haulong infile log 
+   implode intern maknam maknum makunbound minus minusp
+   not ncons null numberp onep plist pntlen portp ptr 
+   quote readlist remob *rset sin sizeof stringp sub1 sqrt symbolp
+   truename type valuep zerop)
+(one-to-two errset flatc outfile patom print status tyo untyi)
+(one-to-three fasl load process)
+(one-to-inf funcall progv)
+(two  allocate alphalessp
+   arrayref assq atan bignum-leftshift *catch cons
+   Divide eq equal freturn
+   get haipart *invmod lsh
+   mfunction mod *mod nthelem putaux putd
+   putdata putdelta putdisc putlength
+   remprop replace rot rplaca rplacd segment set setarg setplist scons
+   signal sstatus sticky-bignum-leftshift *throw
+   vref vrefi-byte vrefi-word vrefi-long)
+   
+(two-to-inf  apply def mapc mapcan mapcar mapcon maplist prog2)
+(three putprop)
+(three-to-five cfasl)
+(three-to-inf boole)
+(four Emuldiv)
+(five marray)
+