Description: interface-from-5.0
Forwarded: not-needed
 TODO: Put a short summary on the line above and replace this paragraph
 with a longer explanation of this change. Complete the meta-information
 with other relevant fields (see below for details). To make it easier, the
 information below has been extracted from the changelog. Adjust it or drop
 it.
 .
 acl2 (6.0-1) unstable; urgency=low
 .
   * New upstream release
Author: Camm Maguire <camm@debian.org>

---
The information above should follow the Patch Tagging Guidelines, please
checkout http://dep.debian.net/deps/dep3/ to learn about the format. Here
are templates for supplementary fields that you might want to add:

Origin: <vendor|upstream|other>, <url of original patch>
Bug: <url in upstream bugtracker>
Bug-Debian: http://bugs.debian.org/<bugnumber>
Bug-Ubuntu: https://launchpad.net/bugs/<bugnumber>
Forwarded: <no|not-needed|url proving that it has been forwarded>
Reviewed-By: <name and email of someone who approved the patch>
Last-Update: <YYYY-MM-DD>

--- /dev/null
+++ acl2-6.0/interface/infix/acl2-formatting.lisp
@@ -0,0 +1,158 @@
+; ACL2 Version 1.9
+
+; Copyright (C) 1989-96 Computational Logic, Inc. (CLI).  All rights reserved.
+
+; Use of this software constitutes agreement with the terms of ACL2
+; license agreement, found in the file LICENSE.
+
+(in-package "ACL2")
+
+(defparameter *infix-error-flg* nil)
+
+(symbol-name 'acl2-output-channel::standard-error-output-0)
+(setf (get 'acl2-output-channel::standard-error-output-0
+           *open-output-channel-type-key*) :character)
+(setf (get 'acl2-output-channel::standard-error-output-0
+           *open-output-channel-key*) *standard-output*)
+
+(defconst *standard-eo* 'acl2-output-channel::standard-error-output-0)
+
+(f-put-global 'standard-eo 'acl2-output-channel::standard-error-output-0 state)
+
+(defun infix-error-fmt (hardp ctx str alist state)
+
+; Almost the same as ACL2 error-fmt.
+
+  (setq *infix-error-flg* t)
+
+  (let ((channel *standard-eo*))	;(f-get-global 'standard-co state)
+    (mv-let (col state)
+      (fmt1 (if hardp
+                "~%~%HARD ACL2 ERROR"
+              "~%~%ACL2 Error")
+            nil 0 channel state nil)
+      (mv-let (col state)
+        (fmt-in-ctx ctx col channel state)
+        (mv-let (col state)
+          (fmt1 str alist col channel state (default-evisc-tuple state))
+          (fmt1 "~%~%" nil col channel state nil))))))
+
+(defun string-output-fn (form)
+  `(let ((saved-stream (get 'acl2-output-channel::standard-character-output-0
+                            *open-output-channel-key*))
+         *infix-error-flg*
+         (saved-fn (symbol-function 'error-fmt)))
+     (unwind-protect
+         (progn
+           (setf (symbol-function 'error-fmt)
+                 (symbol-function 'infix-error-fmt))
+           (let ((ans
+                  (with-output-to-string
+                   (foo)
+                   (setf (get 'acl2-output-channel::standard-character-output-0
+                              *open-output-channel-key*)
+                         foo)
+                   ,form)))
+             (cons *infix-error-flg* ans)))
+       (setf (symbol-function 'error-fmt)
+             saved-fn)
+       (setf (get 'acl2-output-channel::standard-character-output-0
+                  *open-output-channel-key*)
+             saved-stream))))
+
+(defmacro string-output (form)
+  (string-output-fn form))
+
+(defun set-infix-markup-table (tbl state)
+  (f-put-global 'infix-markup-table tbl state))
+
+(defun infix-markup-table (state)
+  (or (and (f-boundp-global 'infix-markup-table state)
+           (f-get-global 'infix-markup-table state))
+      (doc-markup-table state)))
+
+(defun set-infix-char-subst-table (tbl state)
+  (f-put-global 'infix-char-subst-table tbl state))
+
+(defun infix-char-subst-table (state)
+  (or (and (f-boundp-global 'infix-char-subst-table state)
+           (f-get-global 'infix-char-subst-table state))
+      (doc-char-subst-table state)))
+
+;; For examples of markup-tables and char-subst-tables see
+;; scribe-init.lisp and latex-init.lisp
+
+(defun infix-preprocess-doc (str &key
+                              (markup-table (infix-markup-table *the-live-state*))
+                              (char-subst-table (infix-char-subst-table *the-live-state*))
+                              (prefix "")
+                              fmt-alist
+                              (name '|<some name>|)
+                              par-p
+                              &aux (state *the-live-state*))
+  (string-output
+   (cond
+    ((doc-stringp str)
+     (pprogn
+      (print-doc-string-part 0 str prefix markup-table char-subst-table fmt-alist
+                             *standard-co* name par-p state)
+      (print-doc-string-part 1 str prefix markup-table char-subst-table fmt-alist
+                             *standard-co* name par-p state)
+      (print-doc-string-part 2 str prefix markup-table char-subst-table fmt-alist
+                             *standard-co* name par-p state)))
+    ;; Otherwise, print the string, stopping at the first ~/ (if any, else to end of string).
+    ;; Note that unlike the other case, no special effort is made to
+    ;; strip off leading spaces using get-doc-string-de-indent [see below].
+    (t (print-doc-string-part1 str
+                               0
+                               (length str)
+                               0;;(get-doc-string-de-indent str)
+                               prefix
+                               markup-table
+                               char-subst-table
+                               fmt-alist
+                               *standard-co*
+                               name
+                               state
+                               (if par-p :par 0))))))
+
+;;; Compute args for key.
+
+(defun keyword-command-arg-number (key state)
+  (declare (xargs :mode :program))
+  (let ((temp (assoc-eq key (f-get-global 'ld-keyword-aliases state))))
+    (cond (temp (cadr temp))
+	  ((eq key :q) 0)
+	  (t
+	   (let ((sym (intern (symbol-name key) "ACL2"))
+		 (wrld (w state)))
+	     (cond
+	      ((function-symbolp sym wrld)
+	       (length (formals sym wrld)))
+	      ((getprop sym 'macro-body nil 'current-acl2-world wrld)
+	       (let ((args (getprop sym 'macro-args nil 'current-acl2-world wrld)))
+		 (if (no-lambda-keywordsp args)
+		     (length args)
+		     nil)))
+	      (t nil)))))))
+
+;; The following two functions support the reading of 
+;; keyword commands, using ACL2 mechanisms for computing
+;; number of args, if allowed.
+
+(proclaim '(ftype (function (t t) t)
+		  user::read-keyword-form))
+
+(defvar user::acl2-markup-table)
+(defvar user::acl2-char-subst-table)
+
+(defun user::acl2-parse-string (doc)
+  (infix-preprocess-doc doc
+			:markup-table user::acl2-markup-table
+			:char-subst-table user::acl2-char-subst-table))
+
+(defun user::acl2-keywordp (key) (keywordp key))
+
+(defun user::read-keyword-command (key)
+  (user::read-keyword-form key
+			   (keyword-command-arg-number key *the-live-state*)))
--- /dev/null
+++ acl2-6.0/interface/infix/CLI.sty
@@ -0,0 +1,18 @@
+%   CLIverbatim is like the LaTeX verbatim environment except
+% that the characters \ { } $ _ and ^ are NOT transparent.  This means that
+% you can embed control sequences inside of verbatim text, and do math
+% subscripting and superscripting.
+
+\def\CLIdospecials{\do \ \do \&\do \# \do \^^K \do \^^A \do \% \do \~}
+
+\def\@CLIverbatim{\trivlist \item[]\if@minipage\else\vskip\parskip\fi
+\leftskip\@totalleftmargin\rightskip\z@
+\parindent\z@\parfillskip\@flushglue\parskip\z@
+\@tempswafalse \def\par{\if@tempswa\hbox{}\fi\@tempswatrue\@@par}
+\obeylines \small \tt \catcode``=13 \@noligs \let\do\@makeother \CLIdospecials}
+
+\def\CLIverbatim{\@CLIverbatim \frenchspacing\@vobeyspaces}
+\let\endCLIverbatim=\endtrivlist
+
+\def\smtt{\small\tt}
+\def\bm{\smtt}
--- /dev/null
+++ acl2-6.0/interface/infix/scribe-init.lisp
@@ -0,0 +1,565 @@
+; ACL2 Version 1.9
+
+; Copyright (C) 1989-96 Computational Logic, Inc. (CLI).  All rights reserved.
+
+; Use of this software constitutes agreement with the terms of ACL2
+; license agreement, found in the file LICENSE.
+
+
+;; Init file for infix.lisp in Scribe mode.
+;; Feb 20 1992, by MKSmith
+
+;; In order to fix a bug in the AKCL interpreter's use of proclaim.
+;; we depend on this file being compiled and loaded in an environment 
+;; in which infix.lisp has already been loaded.
+;; #+akcl (load-base "akcl-patch.lisp")
+
+(in-package "user")
+
+(format *terminal-io* "Loading the ainfix scribe-init file.")
+
+
+
+;; Mode should actually be set before this file is loaded.
+
+(infix-settings :mode                   "scribe"
+		:extension              "mss"   
+		:op-location            'front  
+		:comment-format         'smith  
+		:format-!-in-comments   nil    
+		:eliminate-top-parens   t       
+		:eliminate-inner-parens nil       
+		:no-index-calls         nil )
+
+
+;; Increase this number to more accurately allow for proper output width.
+(defparameter *rightmost-char-number* 100)
+(defparameter *default-chars-wide* 100)
+(defparameter *latex-indent-number-limit* 100)
+
+(defparameter nqread-normal-clause-enders
+  (append '(#\@) nqread-default-normal-clause-enders))
+
+; THE SCRIBE PRELUDE.
+
+(defparameter *standard-prelude*
+  "@make(clinote)
+@device(postscript)
+@style(leftmargin 1.5 inch,linewidth 5.5 inch, indent 0, 
+       font clitimesroman, indexcase folded)
+
+@enable(index)
+
+@libraryfile(clisymbols)
+@libraryfile(stable)
+
+@comment{Kcrlf is used in @index[] to cause the form to ignore}
+@comment{newlines after the indexing command.  Not what we want in the}
+@comment{forms below.}
+
+@Form(Kcrlf={})
+
+@Modify(format,above 1.2lines,below 1.2 lines)
+@define(st, use t, size -2)
+
+@Define(block,Break Off,Nofill,Spaces Kept,BlankLines kept,Justification off,afterentry {@$})
+@define(nop)
+
+@pageheading(immediate,center={})
+@pagefooting(immediate,center={@value(page)})
+
+")
+
+(defparameter *standard-postlude*
+ "
+")
+
+(defparameter *example-prelude*
+  (concatenate 'string *standard-prelude*
+"
+@standardtable(name BaseTbl, Columns 2, columnwidth 2.5 inch, allcolumns=center, 
+               float,  boxed, flushtop,
+               above 1 line, below 1 line)
+
+Here is a summary of the conventional syntax (~a) in terms of the official syntax
+of the Acl2 logic.
+
+@begin{enumerate}
+
+Variables.  !tx, !ty, !tz, etc. are printed in italics.
+
+Function application.  For any function symbol for which special
+syntax is not given below, an application of the symbol is printed with
+the usual notation; e.g., the term !v(fn x y z) is
+printed as !t(fn x y z).  Note that the function symbol is printed in
+Roman.  In the special case that !qc is a function symbol of no
+arguments, i.e., it is a constant, the term !v(c) is printed merely as
+!t(c), in small caps, with no trailing parentheses.  Because variables are printed in
+italics, there is no confusion between the printing of variables and
+constants.
+
+Other constants.  !tt, !tf, and !tnil are printed in bold.
+Quoted constants are printed in the ordinary syntax of the ACL2 logic,
+in a `typewriter font.'  For example,
+@t{'(a b c)} is still printed just that way.  @t{#b001} is printed
+as !t#b001, @t{#o765} is printed as !t#o765, and @t{#xa9} is printed as
+!t#xa9, representing binary, octal and hexadecimal, respectively.
+
+"))
+
+(defparameter *begin-example-table* "
+@newpage()
+@begin(BaseTbl)
+@tableid(BaseTbl~d)
+@tableHeading(Immediate, RowFormat BaseTblColumnHeadings, 
+              Line {ACL2 Syntax@\\Conventional Syntax})~%"
+  "Needs an argument, integer, in order to give different tables different names.")
+
+(defparameter *end-example-table* "@end(BaseTbl)
+
+")
+
+(defparameter *example-table-size*  32)
+
+(defparameter *example-postlude* "")
+
+;; BASIC BRACKETS AND THEIR QUOTED VERSION.
+
+(defparameter *begin* "{")
+(defparameter *end*   "}")
+
+(defparameter *lbrace* "@nop<{>")
+(defparameter *rbrace* "@nop<}>")
+
+;; NEWLINE PARAMETERS
+
+(defparameter *newline-in-env* "")
+(defparameter *newline-in-text* "")
+
+(defparameter *force-newline-in-env* "")
+(defparameter *force-newline-in-text* "@*")
+
+
+;; ENVIRONMENT BEGIN-END PAIRS
+
+(defparameter *begin-index* "@index{")
+(defparameter *end-index* "@index{")
+
+(defparameter *begin-text-env* "@begin{text,above 1 line,below 1 line}")
+(defparameter *end-text-env*  "@end{text}")
+
+(defparameter *begin-verbatim-env* "@begin{verbatim}")
+(defparameter *end-verbatim-env*  "@end{verbatim}")
+
+(defparameter *begin-format-env*  "@begin{format}")
+(defparameter *end-format-env*    "@end{format}")
+
+(defparameter *begin-emphasis-env*  "@begin{format, FaceCode i}")
+(defparameter *end-emphasis-env*    "@end{format}")
+
+(defparameter *begin-comment-env*  "@begin{comment}")
+(defparameter *end-comment-env*    "@end{comment}")
+
+(defparameter *begin-section-env*  "@section{")
+(defparameter *end-section-env*    "}")
+
+(defparameter *begin-subsection-env*  "@subsection{")
+(defparameter *end-subsection-env*    "}")
+
+(defparameter *begin-tt-env* "@t{")
+(defparameter *end-tt-env*   "}")
+
+(defparameter *begin-string-env* "@st{")
+(defparameter *end-string-env*   "}")
+
+(defparameter *begin-bold-env* "@b{")
+(defparameter *end-bold-env*   "}")
+
+(defparameter *begin-italic-env* "@i{")
+(defparameter *end-italic-env*   "}")
+
+(defparameter *begin-sc-env* "@c{")
+(defparameter *end-sc-env*   "}")
+
+(defparameter *begin-enumerate-env* "@begin{enumerate}")
+(defparameter *end-enumerate-env* "@end{enumerate}")
+(defparameter *begin-item* "
+@begin(multiple)
+")
+(defparameter *end-item* "
+@end(multiple)
+")
+
+(defparameter *mv-bracket-left* "@langle")
+(defparameter *mv-bracket-right* "@rangle")
+
+(defparameter *forall* "@forall ")
+(defparameter *exists* "@exists ")
+
+
+;; TABBING ENVIRONMENT AND TAB OPERATIONS
+
+(defparameter *begin-group-tabbing-env* "@begin{format,group}@tabclear{}")
+
+(defparameter *begin-tabbing-env* "@begin{format}@tabclear{}")
+(defparameter *end-tabbing-env* "@end{format}")
+
+(defun new-tab-row (&optional followed-by-infix-print-term)
+  (declare (ignore followed-by-infix-print-term))
+  (pwrite-char #\Newline))
+
+(defparameter *tab* "@\\")
+(defparameter *flush* "@>")
+
+(defparameter *column-separator* *tab*)
+
+(defparameter *tab-list* nil)
+
+(defparameter *set-margin* "@begin(block)")
+(defparameter *set-tab*    "@^")
+(defparameter *pop-margin* "@end(block)")
+
+(defparameter *default-op-tab-space* "@math{@quad}@ @ @ ")
+(defparameter *indent-string* "@math{@quad}")
+(defparameter *default-indent* 4)
+
+(defun get-op-width-string (op)
+  (declare (ignore op))
+  nil)
+
+(defparameter *noindent* "")
+
+; (defparameter *testmargin* nil)
+
+(defun begin-tabbing ()
+
+; Tabbing environments can be nested in Scribe.  
+; Use this fact with set-margin.
+
+  (setq *tab-list* (cons '(begin-tabs) *tab-list*))
+  ;; (if *testmargin* (format t "~%Begin tabbing : ~a~%" *tab-list*))
+  (princ *begin-tabbing-env*)
+  (setq *infix-loc* *left-margin*))
+
+(defun begin-group-tabbing ()
+
+; Tabbing environments can be nested in Scribe.  
+; Use this fact with set-margin.
+
+  (setq *tab-list* nil)
+  (princ *begin-group-tabbing-env*)
+  (setq *infix-loc* *left-margin*))
+
+(defun end-tabbing ()
+  (sloop while (and *tab-list* (not (equal (caar *tab-list*) 'begin-tabs)))
+	 do (setq *tab-list* (cdr *tab-list*)))
+  (if *tab-list* (setq *tab-list* (cdr *tab-list*)))
+  ;; (if *testmargin* (format t "~%End tabbing : ~a~%" *tab-list*))
+  (princ *end-tabbing-env*))
+
+(defun increase-margin ()
+  (pprin1i *default-op-tab-space*)
+  (set-margin))
+
+(defun set-margin ()
+
+; Generate instructions to set the current indentation.
+; In latex we use tabs, which cause *tabto* to tab to this column in the future.  
+; `Punt' if we hit the limit, by throwing all the way out.
+
+  (cond (*do-not-use-tabs* nil)
+	;; Bump Latex limit way up for Scribe.
+        (t (cond ((= *tabs-in* *latex-indent-number-limit*) 
+                  (throw 'taboverflow t)))
+           (setq *tabs-in* (1+ *tabs-in*))
+	   (pprinc *set-margin*)
+	   (push (cons 'lm *infix-loc*) *tab-list*)
+	   ;; (if *testmargin* (format t "~%Set margin : ~a~%" *tab-list*))
+	   )))
+
+(defun get-margin ()
+  (get-margin2 *tab-list*))
+
+(defun get-margin2 (tl)
+  (let ((setting (car tl)))
+    (cond ((null setting) *left-margin*)
+	  ((eq (car setting) 'lm) (cdr setting))
+	  (t (get-margin2 (cdr tl))))))
+
+(defun begin-flushright ()
+  (pprinc *flush*))
+
+(defun end-flushright ()
+  (pprinc *tab*))
+
+(defun begin-normal-text ()
+  (pprinc *begin-text-env*))
+
+(defun end-normal-text ()
+  (pprinc *end-text-env*))
+
+(defun flushright (form)
+  (begin-flushright)
+  (pprinc form)
+  (end-flushright))
+
+(defun do-tab ()
+
+; The *tab-list* is either NIL, ((LM loc) ...), or ((TAB loc) ...)
+; Only tab if there is something to tab to.
+
+  (cond (*do-not-use-tabs* (pprinc " "))
+	((and *tab-list* (eq (caar *tab-list*) 'tab))
+	 (pprinc *tab*))
+	(t (pprinc " "))))
+
+(defun set-tab (&optional op)
+
+; Generate instructions to set a tab at the current location.
+; `Punt' if we hit the limit, by throwing all the way out.
+
+  (cond (*do-not-use-tabs* nil)
+        (t (cond ((= *tabs-in* *latex-indent-number-limit*) ;Let Latex-Limit hold for Scribe also.
+                  (throw 'taboverflow t)))
+           (setq *tabs-in* (1+ *tabs-in*))
+	   (cond ((and op (get-op-width-string op))
+		  (pprinc (get-op-width-string op)))
+		 (t (pprinc *default-op-tab-space*)))
+           (push (cons 'tab *infix-loc*) *tab-list*)
+	   ;; (if *testmargin* (format t "~%Setting tab : ~a~%" *tab-list*))
+           (pprinc *set-tab*))))
+
+(defun pop-tab ()
+  ;; We don't really remove tabs from the formatted env.
+  ;; Just track them in Lisp.
+  ;; Generate command to `tab to one tab less in'.
+  ;; Do not pop tabs beyond left margin or past the beginning of a tabbing env.
+  (cond (*do-not-use-tabs* nil)
+	((and *tab-list* (eq (caar *tab-list*) 'tab))
+	 (setq *tabs-in* (1- *tabs-in*))
+	 (pop *tab-list*)
+	 ;; (if *testmargin* (format t "~%Popped tab : ~a~%" *tab-list*))
+	 )
+	(t nil)))
+
+(defun pop-margin ()
+  ;; Generate command to `return to one margin less in'.
+  ;; For bookkeepping reasons we pop tabs after the margin.
+  ;; (if *testmargin* (format t "~%Popping margin ...~%"))
+  (cond (*do-not-use-tabs* nil)
+	((and *tab-list* (eq (caar *tab-list*) 'tab))
+	 (pop-tab)
+	 (pop-margin))
+	((and *tab-list* (eq (caar *tab-list*) 'lm))
+	 (setq *tabs-in* (1- *tabs-in*))
+	 (pop *tab-list*)
+	 ;; (if *testmargin* (format t "~%Popped margin : ~a~%" *tab-list*))
+	 (pprinc *pop-margin*))
+	(t nil)))
+
+;; (defun newline-to-current-margin ()
+;;   ;; Generates command for return to current indentation setting.  
+;;   (cond (*do-not-use-tabs* (pprinci " "))
+;; 	(t (pwrite-char #\Newline)
+;; 	   (setq *infix-loc* (get-margin)))))
+
+(defun to-current-margin ()
+  ;; Generates command for return to current indentation setting,
+  ;; unless we are already there.
+  (cond (*do-not-use-tabs* (pprinci " "))
+	((eql *infix-loc* (get-margin)))
+	(t (newline))))
+
+;; (defun force-newline ()
+;;   ;; Forces a newline in running text.
+;;   (pprinc "@*")
+;;   (pwrite-char #\Newline)
+;;   (cond (*do-not-use-tabs*
+;; 	   (setq *infix-loc* *left-margin*))
+;; 	(t (setq *infix-loc* (get-margin)))))
+
+;; (defun force-newline ()
+;;   ;; Forces a newline in running text OR in tabbing env.
+;;   (if (null *tab-list*)
+;;       (progn (pprinc "@*")
+;; 	     (pwrite-char #\Newline)
+;; 	     (cond (*do-not-use-tabs*
+;; 		    (setq *infix-loc* *left-margin*))
+;; 		   (t (setq *infix-loc* (get-margin)))))
+;;       (cond (*do-not-use-tabs* (pprinci " "))
+;; 	    (t (pwrite-char #\Newline)
+;; 	       (setq *infix-loc* (get-margin))))))
+
+(defun set-left-margin ()
+  (cond ((< *infix-loc* *left-margin*)
+	 (sloop for i from *infix-loc* to (- *left-margin* 1)
+		  do (pwrite-char #\Space))
+	 (pprinc "@$"))))
+
+
+;; FONTS
+
+(defparameter *function-font* "@r")	; Roman.  sc = small caps
+
+(defun roman-font (term)
+  (pprinc *function-font*)
+  (pprinc "{")
+  (print-atom term)
+  (pprinc "}"))
+
+
+;; MATH ENV AND OPERATORS
+
+(defparameter *neg-str*  "@not")
+
+(defparameter *math-format* "@math{~a}")
+(defparameter *math-begin* "@math{")
+(defparameter *math-end* "}")
+
+;; These must be enclosed in a math env.  Tried using a @quad, but it is too thick.
+(defparameter *math-thick-space* "@ ")
+(defparameter *math-space* "##")         ; # is a thin space
+(defparameter *math-thin-space* "#")
+
+(defparameter *subscript* "@-")
+
+(defparameter *begin-subscript* "@-{")
+(defparameter *end-subscript* "}")
+
+;; MISC.
+
+(defparameter *newpage* "@newpage()")
+
+(defparameter *comma-atsign* ",@@")
+(defparameter *caret* "^")
+
+(defparameter *dotted-pair-separator* " . ")      
+(defparameter *dotted-pair-separator-newline* ". ")
+
+(defparameter *no-tab-event-trailer* "~%~%")
+(defparameter *print-default-event-header* "~%@c{Event}:   ")
+(defparameter *print-default-lisp-header* "~%@c{Lisp}:   ")
+
+(defparameter *print-default-command-header*  "~%")
+(defparameter *no-tab-command-trailer* "~%~%")
+
+;; OTHER FUNCTIONS
+
+;; Should both be `(#\@ @\}) but we handle them individually in the appropriate 
+;; spots in the two following functions.
+(defparameter doc-special-chars nil)
+(defparameter doc-index-specials nil)
+
+(defparameter doc-other-chars   nil)
+
+;; We didn't compile the following because the compiler declaration
+;; in Sinfix, through a bug in AKCL, caused this routine to produce
+;; spurious results.
+
+;; The patch to akcl that is loaded in sinfix should fix this problem.
+;; Other lisps shouldn't need it.
+;; These use to be of the form (eval-when (load) (eval '<defn>))
+
+(eval-when (load) (eval
+'(defun handle-special-chars (char)
+  ;; USED BY PRINT-ATOM.  CHAR is local to print-atom.
+  ;; We don't use the global, DOC-SPECIAL-CHARS, since there are 
+  ;; only two, @ and }, and we do something different in each case. 
+  (cond ((char= char #\@) (pprinc "@@") (incf *infix-loc* 1))
+	((char= char #\}) (pprinc *rbrace*) (incf *infix-loc* 1))
+
+	;; Atoms printed in all lower case.
+
+	(t (pwrite-char (if (eq *print-case* :downcase)
+			    (char-downcase char)
+			    char)))))
+))
+
+(eval-when (load) (eval
+'(defun handle-special-chars-in-string (char)
+  ;; USED BY PRINT-ATOM.  CHAR is local to print-atom.
+  (cond ((char= char #\@) (pprinc "@@")	 (incf *infix-loc* 1))
+	((char= char #\}) (pprinc *rbrace*) (incf *infix-loc* 1))
+	(t (pwrite-char char))))
+))
+
+;; PRINTING INDEX ENTRIES
+
+;; We don't bother to count braces in Scribe, we just quote them.
+
+(defun index (x &optional subkind)
+  (pprinc *begin-index*)
+  (let ((str (if (stringp x) x (symbol-name x)))
+        (num-chars 0)
+        ;(inserted-excl nil)
+	)
+
+    (if subkind
+	(cond ((stringp subkind) (setq str (concatenate 'string str ", " subkind)))
+	      ((symbolp subkind) (setq str (concatenate 'string str ", " (string subkind))))
+	      (t nil)))
+
+    (sloop for i below (length str)
+             for char = (char (the string str) (the fixnum i))
+             until (> num-chars *index-entry-max*)  
+
+	     ;; Quote special Scribe characters as @ & }.
+
+             do (cond ((char= char #\@) (pprinc "@@") (incf num-chars 2))
+		      ((char= char #\}) (pprinc *rbrace*) (incf num-chars 2))
+
+		      (t (pwrite-char (if (eq *print-case* :downcase)
+					  (char-downcase char)
+					  char))
+			 (incf num-chars 1)))
+             finally (cond ((> num-chars *index-entry-max*)
+			    (pformat *terminal-io*
+				     "~% Warning: Index entry for ~a truncated to ~a characters. ~%"
+				     x num-chars)
+			    (pprinc "...")))
+	     ))
+  (pprinc *end*))
+
+(defun skip-index-entries ()
+  ;; We are looking at a backslash. In Tex mode we need to skip to the end 
+  ;; of the entry, because we may add !'s.  In Scribe mode this is just NIL.
+  nil)
+
+(defun adjust-tabbing-env ()
+  ;; We are looking at a backslash. In Tex mode we may need to check for 
+  ;; some special cases.
+  ;; In Scribe mode this is just NIL.
+  nil)
+
+(defparameter acl2-char-subst-table
+ '((#\@ #\@ #\@)))
+
+(defparameter acl2-markup-table
+  '(("-"   .   "@emdash{}")
+    ("B"   .   "@b{~sa}")
+    ("BF"  .   "~%@begin{format}") 
+    ("BID" .   "")		      ;begin implementation dependent
+    ("BQ"  .   "~%@begin{quotation}")
+    ("BV"  .   "~%@begin{verbatim}")
+    ("C"   .   "@t{~sa}")	      ;originally @code, but we don't want `' in info file
+    ("EF"  .   "@end{format}~%")
+    ("EID" .   "")		      ;end implementation dependent
+    ("EM"  .   "@i{~sa}")	      ;emphasis
+    ("EQ"  .   "~%@end{quotation}~%") ;TexInfo needs leading line break to 
+				      ;avoid problems with @refill
+    ("EV"  .   "@end{verbatim}~%")
+    ("I"   .   "@i{~sa}")
+    ("ID"  .   "~sa")		      ;implementation dependent
+    ("IL"  .   "~sa")
+    ("ILC" .  "@t{~sa}")	      ;originally @code, but we don't want `' in info file
+    ("L"   .  "See ~sA")   
+    ("NL"  .  "@*~%")
+    ("PAR" .  "")		      ;paragraph mark, of no significance for scribe
+    ("PL"  .  "see ~sA")	      ;used for parenthetical crossrefs
+    ("SC"  .  "@c{~sa}")	      ;small caps
+    ("ST"  .  "@b{~sa}")	      ;strong emphasis
+    ("T"   .  "@t{~sa}")
+    ("TERMINAL" . "")		      ; terminal only, ignore
+    ))
+
+
--- /dev/null
+++ acl2-6.0/interface/infix/sloop.lisp
@@ -0,0 +1,1098 @@
+;;; -*- Mode:LISP; Package: (SLOOP LISP);  Syntax:COMMON-LISP; Base:10 -*- ;;;;;;;;
+;;;                                                                    ;;;;;
+;;;     Copyright (c) 1985,86 by William Schelter,                     ;;;;;
+;;;     All rights reserved                                            ;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;;Report bugs to atp.schelter@r20.utexas.edu
+;;It comes with ABSOLUTELY NO WARRANTY but we hope it is useful.
+
+
+;;The following code is meant to run in COMMON LISP and to provide
+;;extensive iteration facilities, with very high backwards compatibility
+;;with the traditional loop macro. It is meant to be publicly available!
+;;Anyone is hereby given permission to copy it provided he does not make
+;;ANY changes to the file unless he is William Schelter.  He may change
+;;the behavior after loading it by resetting the global variables such
+;;as like *Use-locatives*, *automatic-declarations*,..  listed at the
+;;beginning of this file.  The original of this file is on
+;;r20.utexas.edu:<atp.schelter>sloop.lisp  I am happy to accept suggestions
+;;for different defaults for various implementations, or for improvements.
+
+;;If you want to redefine the common lisp loop you may include in your code:
+;;(defmacro loop (&body body)
+;;  (parse-loop body))
+
+;;         Principal New Features
+
+;;Sloop is extremely user extensible so that you may easily redefine most
+;;behavior, or add additional collections, and paths.  There are a number
+;;of such examples defined in this file, including such constructs as
+;;"for V in-fringe X", "sum V", "averaging V", "for SYM in-package Y",
+;;"collate V" (for collecting X into an ordered list), "for (ELT I) in-array AR",
+;;"for (KEY ELT) in-table FOO" (if foo is a hash table).  And of course
+;;you can combine any collection method with any path.
+;;Also there is iteration over products so that you may write
+;;(sloop for I below K
+;;       sloop (for J below I
+;;          	    collecting (foo I J)))
+;;Declare is fully supported.  The syntax would be
+;;(sloop for u in l with v = 0
+;;       declare (fixnum u v)
+;;       do ....)
+
+;;This extensibility is gained by the ability to define a "loop-macro",
+;;which plays a role analagous to an ordiary lisp macro.  See eg.
+;;definitions near that of "averaging".  Essentially a "loop-macro"
+;;takes some arguments (supplied from the body of the loop following its
+;;occurrence, and returns a new form to be stuffed onto the front of the
+;;loop form, in place of it and its arguments).
+ 
+;;Compile notes:
+;;For dec-20 clisp load the lisp file before compiling.
+
+
+;;there seems to be no unanimity about what in-package etc. does on loading
+;;and compiling a file.  The following is as close to the examples in
+;;the Common Lisp manual, as we could make it.
+;;The user should put (require "SLOOP") and then (use-package "SLOOP") 
+;;early in his init file.  Note use of the string to avoid interning 'sloop
+;;in some other package.
+
+
+(in-package "SLOOP"  :use '(LISP))  
+(eval-when (compile eval load)
+(provide "SLOOP")
+(export '(loop-return sloop def-loop-collect def-loop-map
+		      def-loop-for def-loop-macro local-finish
+		      loop-finish) (find-package "SLOOP"))
+)
+
+;;some variables that may be changed to suit different implementations:
+
+(eval-when (compile load eval)
+
+(defparameter *use-locatives* nil "See sloop.lisp")   ;#+lispm t #-lispm nil 
+;;If t should have locf, such that (setf b nil) (setq a (locf b)) then if
+;;(setf (cdr a) (cons 3 nil)) b==>(3).  This is useful for building lists
+;;starting with a variable pointing to nil, since otherwise we must check
+;;each time if the list has really been started, before we do a 
+;;(setf (cdr b) ..)
+
+(defparameter *Automatic-declarations*
+	      #+lispm nil
+  #-lispm				
+  '(:from fixnum
+	  :in #+kcl object #-kcl t
+	  :collect #+kcl object #-kcl t ) "See sloop.lisp")
+;; some other reasonable ones would be :count fixnum :max fixnum
+;;Automatic declarations for variables in the stepping and collecting,
+;;so for i below n, gives i and n a :from declaration (here fixnum)
+;;for item in lis, gives (declare (t item))
+
+(defvar *type-check* t "If t adds a type check on bounds of from loop if there
+is and automatic declare")
+
+(defparameter *macroexpand-hook-for-no-copy* #-(or lmi ti) 'funcall #+(or lmi ti) t)
+;;some lisps remember a macro so that (loop-return) will expand eq forms
+;;always in the same manner, even if the form is in a macrolet! To defeat this feature
+;;we copy all macro expansions unless *macro-expand-hook* = *macroexpand-hook-for-no-copy*
+)
+
+#+kcl (eval-when (compile) (proclaim '(optimize (safety 2) (space 2))))
+
+;;to do
+;;Fix (declare (joe (type (array fixnum)))) type for declarations.
+
+;;*****ONLY CONDITIONALIZATIONS BELOW HERE SHOULD BE FOR BUG FIXES******
+;;eg. some  kcls don't return nil from a prog by default!
+
+;;all macros here in here.
+(eval-when (compile eval load)
+
+(defparameter *sloop-translations* '((appending . append)
+			 ((collecting collect) . collect)
+			 ((maximizing maximize) . maximize)
+			 ((minimizing minimize) . minimize)
+			 (nconcing . nconc)
+			 ((count counting) . count)
+			 (summing . sum)
+			 (if . when)
+			 (as . for)
+			 (in-fringe . in-fringe)
+			 (collate . collate)
+			 (in-table . in-table)
+			 (in-carefully . in-carefully)
+			 (averaging . averaging)
+			 (repeat . repeat)
+			 (first-use . first-use)
+			 (in-array . in-array))
+  "A list of cons's where the translation is the cdr, and the car
+is a list of names or name to be translated.  Essentially allows 'globalizing'
+a symbol for the purposes of being a keyword in a sloop")
+
+
+(defparameter *additional-collections* nil)
+
+(defmacro lcase (item &body body)
+  (let (bod last-case tem)
+    (do ((rest body (cdr rest)) (v))
+	((or last-case (null rest)))
+      (setq  v (car rest))
+      (push
+	(cond ((eql (car v) t) (setq last-case t) v)
+	      ((eql (car v) :collect)
+	       `((loop-collect-keyword-p .item.) ,@ (cdr v)))
+	      ((eql (car v) :no-body)
+	       `((parse-no-body  .item.) ,@ (cdr v)))
+	      ((setq tem
+		     (member (car v) '(:sloop-macro :sloop-for :sloop-map)))
+	       `((and (symbolp .item.)(get .item. ,(car tem))) ,@ (cdr v)))
+	      (t
+	       `((l-equal .item. ',(car v)) ,@ (cdr v))))
+	bod))
+    (or last-case (push `(t (error "lcase fell off end ~a  " .item.)) bod))
+    `(let ((.item. (translate-name ,item)))
+       (cond ,@ (nreverse bod)))))
+
+;;some cl implementations lack define-setf-method and others have already defined this.
+;;so we will change the definition of desetq to not use setf.
+;(define-setf-method cons (a b)
+;  (let ((store (gensym "store")))
+;    (values nil nil (list store)
+;	    `(progn ,@ (and a  `((setf ,a (car ,store))))
+;		    ,@ (and b  `((setf ,b (cdr ,store)))))
+;	    `(error "You should not be setting this"))))
+
+;(defmacro cons-for-setf (form)
+;  (cond ((symbolp form) form)
+;	((consp form)
+;	 (cond ((cdr form)
+;		`(cons (cons-for-setf ,(car form))  (cons-for-setf  ,(cdr form))))
+;	       (t `(cons (cons-for-setf ,(car form)) nil))))))
+
+;(defmacro desetq (form val)
+;  "(desetq (a b) '(3 4)) would work.  This is destructured setq"
+;  (cond ((symbolp form) `(setq ,form ,val))
+;	(t
+;	 `(setf (cons-for-setf ,form) ,val))))
+
+(defun desetq1 (form val)
+	    (cond ((symbolp form)
+		   (and form `(setf ,form ,val)))
+		  ((consp form)
+		   `(progn ,(desetq1 (car form) `(car ,val))
+			   ,@ (if (consp (cdr form)) (list(desetq1 (cdr form) `(cdr ,val)))
+				  (and (cdr form) `((setf ,(cdr form) (cdr ,val)))))))
+		  (t (error ""))))
+
+(defmacro desetq (form val)
+  (cond ((atom val) (desetq1 form val))
+	(t (let ((value (gensym)))
+	     `(let ((,value ,val)) , (desetq1 form value))))))
+
+(defmacro loop-return (&rest vals)
+  (cond ((<=  (length vals) 1)
+	 `(return ,@ vals))
+	(t`(return (values  ,@ vals)))))
+
+(defmacro loop-finish ()
+  `(go finish-loop))
+
+(defmacro local-finish ()
+  `(go finish-loop))
+
+(defmacro sloop (&body body)
+  (parse-loop body))
+  
+(defmacro def-loop-map (name args &body body)
+  (def-loop-internal name args body 'map))
+(defmacro def-loop-for (name args &body body )
+  (def-loop-internal name args body 'for nil 1))
+(defmacro def-loop-macro (name args &body body)
+  (def-loop-internal name args body 'macro))
+(defmacro def-loop-collect (name arglist &body body )
+       "Define function of 2 args arglist= (collect-var value-to-collect)"
+  (def-loop-internal name arglist body 'collect '*additional-collections* 2 2))
+
+(defmacro sloop-swap ()
+ `(progn (rotatef a *loop-bindings*)
+  (rotatef b  *loop-prologue*)
+  (rotatef c *loop-epilogue*)
+  (rotatef e *loop-end-test*)
+  (rotatef f *loop-increment*)
+  (setf *inner-sloop* (not *inner-sloop*))
+  ))
+
+)
+
+(defun l-equal (a b)
+  (and (symbolp a)
+       (cond ((symbolp b)
+	      (equal (symbol-name a) (symbol-name b)))
+	     ((listp b)
+	      (member  a b :test 'l-equal)))))
+
+(defun loop-collect-keyword-p (command)
+  (or (member command '(collect append nconc sum count) :test 'l-equal)
+      (find command *additional-collections* :test 'l-equal)))
+ 			 
+(defun translate-name (name)
+  (cond ((and (symbolp name)
+	      (cdar (member name *sloop-translations* :test 'l-equal :key 'car))))
+	(t name)))
+
+(defun loop-pop ()
+  (declare (special *last-val* *loop-form*))
+  (cond (*loop-form*
+          (setq *last-val* (pop *loop-form*)))
+	(t (setq *last-val* 'empty-form) nil)))
+
+(defun loop-un-pop ()  (declare (special *last-val* *loop-form*))
+  (case *last-val*
+	(empty-form nil)
+	(already-un-popped (error "you are un-popping without popping"))
+	(t  (push *last-val* *loop-form*) (setf *last-val* 'alread-un-popped))))
+
+(defun loop-peek () (declare (special *last-val* *loop-form*))
+   (car *loop-form*))
+
+(defun loop-let-bindings(binds)
+  (do ((v (car binds) (cdr v)))
+      ((null v) (nreverse (car binds)))
+      (or (cdar v) (setf (car v) (caar v)))))
+
+(defun parse-loop (form &aux inner-body)
+  (let ((*loop-form* form)
+	(*Automatic-declarations* *Automatic-declarations*)
+	*last-val* *loop-map* 
+	*loop-body* 
+	*loop-name*
+	*loop-prologue* *inner-sloop*
+	*loop-epilogue* *loop-increment*
+	*loop-collect-pointers*  *loop-map-declares*
+	*loop-collect-var* 	*no-declare*
+	*loop-end-test*
+	*loop-bindings*
+	*product-for* local-macros
+	(finish-loop 'finish-loop)
+	)
+    (declare (special *loop-form* *last-val* *loop-map* 
+		      *loop-collect-pointers*
+		      *loop-name* *inner-sloop*
+		      *loop-body*
+		      *loop-prologue* 
+		      *no-declare*
+		      *loop-bindings*
+		      *loop-collect-var*  *loop-map-declares*
+		      *loop-epilogue* *loop-increment*
+		      *loop-end-test* *product-for*
+		      ))
+    (unless (and (symbolp (car *loop-form*))  (car *loop-form*))
+      (push 'do  *loop-form*)) ;compatible with common lisp loop..
+    (parse-loop1)
+    (when (or *loop-map* *product-for*)
+      (or *loop-name* (setf *loop-name* (gensym "SLOOP")))
+      (and (eql 'finish-loop finish-loop)
+	   (setf finish-loop (gensym "FINISH"))))
+    ;some one might use local-finish,local-return or loop-finish they might be bound at an outer level.
+    ;we have to always include this since loop-return may be being bound outside.
+    (and  ; *loop-name*
+	      (push 
+	   `(loop-return (&rest vals) `(return-from ,',*loop-name* (values ,@ vals)))
+	   local-macros))
+    (when  t ;; (or (> *loop-level* 1) (not (eql finish-loop 'finish-loop)))
+      (push 	 `(loop-finish () `(go ,',finish-loop)) local-macros)
+      (push 	 `(local-finish () `(go ,',finish-loop)) local-macros))
+    (and *loop-collect-var*
+	 (push   `(return-from ,*loop-name* , *loop-collect-var*)
+		 *loop-epilogue*))
+    (setq inner-body (append  *loop-end-test*
+			      (nreverse *loop-body*)
+			      (nreverse	*loop-increment*)))
+    (cond (*loop-map*
+	   (setq inner-body (substitute-sloop-body inner-body)))
+	  (t (setf inner-body (cons 'next-loop
+				    (append inner-body '((go next-loop)))))))
+    (let ((bod 
+	    `(macrolet ,local-macros
+	       (block ,*loop-name*
+		 (tagbody
+		     ,@ (append
+		          (nreverse *loop-prologue*)
+			  inner-body
+			  `(,finish-loop)
+			  (nreverse *loop-epilogue*)
+			  #+kcl '((loop-return  nil))))))
+	    
+	    ))
+      ;;temp-fix..should not be necessary but some lisps cache macro expansions.
+      ;;and ignore the macrolet!!
+      (unless  (eql *macroexpand-hook* *macroexpand-hook-for-no-copy*)
+	(setf bod (copy-tree bod)))
+      (dolist (v *loop-bindings*)
+	(setf bod
+	      `(let ,(loop-let-bindings v) ,@(and (cdr v) `(,(cons 'declare (cdr v))))
+		    ,bod)))
+      bod
+      ))) 
+
+(defun parse-loop1 ()
+  (declare (special *loop-form*
+		    *loop-body* *loop-increment*
+		    *no-declare* *loop-end-test*
+		    *loop-name* ))
+  (lcase (loop-peek)
+     (named (loop-pop) (setq *loop-name* (loop-pop)))
+     (t nil))
+  (do ((v (loop-pop) (loop-pop)))
+      ((and (null v) (null *loop-form*)))
+    (lcase v
+      (:no-body)
+      (for (parse-loop-for))
+      (while (push
+	       `(or ,(loop-pop) (local-finish))  *loop-body*))
+      (until (push
+	       `(and ,(loop-pop) (local-finish))  *loop-body*))
+      (do (setq *loop-body* (append (parse-loop-do) *loop-body*)))
+      ((when unless) (setq *loop-body* (append (parse-loop-when) *loop-body*)))
+      (:collect      (setq *loop-body* (append (parse-loop-collect) *loop-body*)))
+      )))
+
+
+(defun parse-no-body (com &aux (found t) (first t))
+  "Reads successive no-body-contribution type forms, like declare, initially, etc.
+which can occur anywhere. Returns t if it finds some
+otherwise nil"
+  (declare (special *loop-form*
+		    *loop-body*
+		    *loop-increment*
+		    *no-declare* *loop-end-test*
+		    *loop-name* ))
+  (do ((v com (loop-pop)))
+      ((null (or first *loop-form*)))
+      (lcase v
+	((initially finally)(parse-loop-initially v))
+	(nil nil)
+	(with      (parse-loop-with))
+	(declare   (parse-loop-declare (loop-pop) t))
+	(nodeclare  (setq *no-declare* (loop-pop)))  ;take argument to be consistent.
+	(increment (setq *loop-increment* (append (parse-loop-do) *loop-increment*)))
+	(end-test  (setq *loop-end-test* (append (parse-loop-do) *loop-end-test*)))
+	(with-unique (parse-loop-with nil t))
+	(:sloop-macro (parse-loop-macro v :sloop-macro))
+	(t
+	 (cond (first
+		   (setf found nil))
+		  (t (loop-un-pop)))
+	    (return 'done)))
+      (setf first nil))
+  found)
+
+(defun parse-loop-with (&optional and-with only-if-not-there)
+  (let ((var  (loop-pop)))
+    (lcase (loop-peek)
+      (= (loop-pop)
+	 (or (symbolp var) (error "Not a variable ~a" var))
+	 (loop-add-binding var (loop-pop) (not and-with) nil nil t only-if-not-there))
+      (t (loop-add-temps var nil nil (not and-with) only-if-not-there)))
+    (lcase (loop-peek)
+      (and (loop-pop)
+	   (lcase (loop-pop)
+	     (with (parse-loop-with t ))
+	     (with-unique (parse-loop-with t t))
+	     (t (loop-un-pop) (parse-loop-with t))
+	     ))
+      (t nil))))
+
+(defun parse-loop-do (&aux result)
+  (declare (special *loop-form*))
+  (do ((v (loop-pop) (loop-pop)) )
+      (())
+    (cond
+      ((listp v)
+       (push v result)
+       (or *loop-form* (return 'done)))
+      (t (loop-un-pop) (return 'done))))
+  (or result (error "empty clause"))
+  result)
+  
+(defun parse-loop-initially (command )
+  (declare (special *loop-prologue* *loop-epilogue* *loop-bindings*))
+  (lcase command
+    (initially (let ((form (parse-loop-do)))
+		 (dolist (v (nreverse form))
+		   (cond ((and (listp v)
+			       (member (car v) '(setf setq))
+			       (eql (length v) 3)
+			       (symbolp   (second v))
+			       (constantp (third v))
+			       (loop-add-binding (second v) (third v) nil nil nil t t)
+			       ))
+			 (t (setf *loop-prologue* (cons v *loop-prologue*)))))))
+    (finally
+      (setf *loop-epilogue* (append (parse-loop-do) *loop-epilogue*)))))
+
+(defun parse-one-when-clause ( &aux this-case  (want 'body) v)
+  (declare (special *loop-form*))
+  (prog nil
+	next-loop
+	   (and (null *loop-form*) (return 'done))
+	   (setq v (loop-pop))
+    (lcase v
+      (:no-body)
+      (:collect (or (eql 'body want) (go finish))
+		(setq this-case (append  (parse-loop-collect) this-case))
+		(setq want 'and))
+      (when  (or (eql 'body want) (go finish))
+	(setq this-case (append   (parse-loop-when) this-case))
+		(setq want 'and))
+      (do    (or (eql 'body want) (go finish))
+	   (setq this-case (append   (parse-loop-do) this-case))
+		(setq want 'and))
+      (and    (or (eql 'and  want) (error "Premature AND"))
+	   (setq want 'body))
+      (t  (loop-un-pop)(return 'done)))
+    (go next-loop)
+    finish
+    (loop-un-pop))
+  (or this-case (error "Hanging conditional"))
+  this-case)
+
+
+(defun parse-loop-when (&aux initial else else-clause )
+  (declare (special *last-val* ))
+  (let ((test (cond ((l-equal *last-val* 'unless) `(not , (loop-pop)))
+		    (t (loop-pop)))))
+    (setq initial (parse-one-when-clause))
+    (lcase (loop-peek)
+      (else
+	(loop-pop)
+	(setq else t)
+	(setq else-clause (parse-one-when-clause)))
+      (t nil))
+  `((cond (,test ,@ (nreverse initial))
+	 ,@ (and else `((t ,@ (nreverse else-clause))))))))
+
+(defun pointer-for-collect (collect-var)
+  (declare (special *loop-collect-pointers*))
+  (or (cdr (assoc collect-var *loop-collect-pointers*))
+      (let ((sym(loop-add-binding (gensym "POIN") nil nil :collect )))
+	(push (cons collect-var sym)
+	      *loop-collect-pointers*)
+	sym)))
+
+(defun parse-loop-collect ( &aux collect-var pointer name-val)
+  (declare (special *last-val* *loop-body* *loop-collect-var*
+		    *loop-collect-pointers* *inner-sloop*
+		    *loop-prologue* ))
+  (and *inner-sloop* (throw 'collect nil))
+  (let ((command   *last-val*)
+	(val (loop-pop)))
+    (lcase (loop-pop)
+      (into (loop-add-binding (setq collect-var (loop-pop)) nil nil t nil t ))
+      (t (loop-un-pop)
+	 (cond (*loop-collect-var* (setf collect-var *loop-collect-var*))
+	       (t  (setf collect-var
+			 (setf *loop-collect-var*
+			       (loop-add-binding (gensym "COLL") nil )))))))
+    (lcase command
+      ((append nconc collect)
+       (setf pointer (pointer-for-collect collect-var))
+       (cond (*use-locatives*
+	      (pushnew `(setf ,pointer
+			      (locf ,collect-var)) *loop-prologue* :test 'equal)))
+       (lcase command
+	 ( append
+	  (unless (and (listp val) (eql (car val) 'list))
+	    (setf val `(copy-list ,val))))
+	 (t nil)))
+      (t nil))
+    (cond ((and  (listp val) (not *use-locatives*))
+	   (setq name-val (loop-add-binding (gensym "VAL") nil nil)))
+	  (t (setf name-val val)))
+    (let
+      ((result
+	 (lcase command
+	   ((nconc append)
+	    (let ((set-pointer `(and (setf (cdr ,pointer) ,name-val)
+				     (setf ,pointer (last (cdr ,pointer))))))
+	      (cond (*use-locatives*
+		     (list set-pointer))
+		    (t
+		     `((cond (,pointer ,set-pointer)
+			     (t (setf ,pointer (last (setf ,collect-var ,name-val))))))))))
+	   (collect
+	     (cond (*use-locatives*
+		    `((setf (cdr ,pointer) (setf ,pointer (cons ,name-val nil)))))
+		   (t `((cond (,pointer (setf (cdr ,pointer)
+					      (setf ,pointer (cons ,name-val nil))))
+			      (t (setf ,collect-var
+				       (setf ,pointer (cons ,name-val nil)))))))))
+	   (t (setq command (translate-name command))
+	     (cond ((find command *additional-collections* :test 'l-equal)
+		     (loop-parse-additional-collections command collect-var name-val))
+		    (t (error "loop fell off end ~a" command)))))))
+      (cond ((eql name-val val)
+	     result)
+	    (t (nconc result `((setf ,name-val ,val) )))))))
+
+(defun loop-parse-additional-collections (command collect-var name-val &aux eachtime)
+  (declare (special *loop-prologue* *last-val* *loop-collect-var* *loop-epilogue* ))
+  (let* ((com  (find command *additional-collections* :test 'l-equal))
+	 (helper (get com :sloop-collect)))
+    (let ((form (funcall helper collect-var name-val)))
+      (let ((*loop-form* form) *last-val*)
+	(declare (special  *loop-form* *last-val*))
+	(do ((v (loop-pop) (loop-pop)))
+	    ((null *loop-form*))
+	  (lcase v
+	    (:no-body)
+	    (do (setq eachtime (parse-loop-do)))))
+	eachtime))))
+
+(defun the-type (symbol type)
+  (declare (special *no-declare*))
+  (and *no-declare* (setf type nil))
+  (and type (setf type (or (getf *Automatic-declarations* type)
+			   (and  (not (keywordp type)) type))))
+  (and (consp type) (eq (car type) 'type) (setf type (second  type)))
+  (cond (type (list 'the type symbol ))
+	(t symbol)))
+
+;;
+
+(defun type-error ()
+  (error "While checking a bound of a sloop, I found the wrong type 
+for something in *automatic-declarations*.  Perhaps your limit is wrong? 
+If not either use nodeclare t or set *automatic-declarations* to nil. 
+recompile."))
+
+
+;;this puts down code to check that automatic declarations induced by 
+;; :from are indeed valid!  It checks both ends of the interval, and
+;;so need not check the numbers in between.
+
+(defun make-value (value type-key &aux type )
+  (declare (special *no-declare*))
+  (cond ((and
+	  (not *no-declare*)
+	  *type-check*
+	  (eq type-key :from)
+	  (setq type (getf  *Automatic-declarations* type-key)))
+	 (setq type
+	       (cond ((and (consp type)
+			   (eq (car type) 'type))
+		      (second type))
+		     (t type)))
+	 (cond ((constantp value)
+		(or (typep value type)
+		    (error
+		     "Sloop found the type of ~a was not type ~a,~
+                      Maybe you want to insert SLOOP NODECLARE T ..."
+		     value
+		     type))
+		(list value))
+	 (t  (let (chk)
+	       
+	       `((let ,(cond ((atom value)
+			      nil)
+			     (t `((,(setq chk(gensym)) ,value))))
+		   (or (typep ,(or chk value) ',type) (type-error))
+		   ,(or chk value)))))))
+	(t (list value))))
+
+
+;;keep track of the bindings in a list *loop-bindings*
+;;each element of the list will give rise to a different let.
+;;the car will be the variable bindings,
+;;the cdr the declarations.
+
+
+(defun loop-add-binding
+       (variable value &optional (new-level t) type force-type (force-new-value t)
+			 only-if-not-there &aux tem)
+  "Add a variable binding to the current or new level.
+ If FORCE-TYPE, ignore a *no-declare*.
+ If ONLY-IF-NOT-THERE, check all levels."
+  (declare (special *loop-bindings*))
+  (when  (or new-level (null *loop-bindings*)) (push (cons nil nil) *loop-bindings*))
+  (cond ((setq tem (assoc variable (caar  *loop-bindings*) ))
+	 (and force-new-value
+	      (setf (cdr tem) (and value (make-value value type)))))
+	((and (or only-if-not-there (and (null (symbol-package variable))
+					 (constantp value)))
+	      (dolist (v (cdr *loop-bindings*))
+		(cond ((setq tem (assoc variable (car v)))
+		       (and force-new-value
+			    (setf (cdr tem)
+				  (and value (make-value value type))))
+		       (return t))))))
+	(t (push (cons variable  (and value (make-value value type)))
+		 (caar *loop-bindings*))))
+  (and type (loop-declare-binding variable type force-type))
+  variable)
+
+;(defmacro nth-level (n) `(nth ,n *loop-bindings*))
+;if x = (nth i *loop-bindings*)
+;(defmacro binding-declares (x) `(cdr ,x)) ;(cons 'declare (binding-declares x)) to get honest declare statement
+;(defmacro binding-values (x) `(car ,x))  ;(let (binding-values x) ) to get let.
+
+(defun loop-declare-binding (var type force-type &optional odd-type
+				 &aux found tem)
+  (declare (special *loop-bindings* *Automatic-declarations*
+		    *no-declare* *loop-map*))
+  odd-type ;;ignored
+  (and type (setf type (or (getf *Automatic-declarations* type)
+			   (and  (not (keywordp type)) type))))
+  (when (and type(or force-type (null *no-declare*)))
+    (dolist (v *loop-bindings*)
+      (cond ((assoc var (car v)) (setf found t)
+	     (do ((decs (cdr v) (cdr decs)))
+		 ((null decs) (push nil (cdr v))(setf tem (cdr v)))
+		 (when (or (and (eq (caar decs) 'type)
+				(eq (third (car decs)) var))
+			   (eql (second (car decs)) var))
+		       (setf tem decs) (return 'done)))
+	     (setf (car tem)
+		   (cond ((and (consp type) (eq (car type) 'type))
+			  (list 'type (second type) var))
+			 (t (list type var))))
+
+	     (and  found (return 'done)))))
+    (or found *loop-map* (error "Could not find variable ~a in bindings" var)))
+  var)
+
+(defun parse-loop-declare (&optional (decl-list (loop-pop)) (force t))
+  (let ((type (car decl-list)) odd-type)
+    (cond ((eq type 'type)
+	   (setf decl-list (cdr decl-list) type (car decl-list) odd-type t)))
+    (dolist (v (cdr decl-list))
+      (loop-declare-binding v (car decl-list) force odd-type))))
+	
+(defun loop-add-temps (form &optional val type new-level only-if-not-there)
+  (cond ((null form))
+	((symbolp form)
+	 (loop-add-binding form val new-level type nil  t only-if-not-there))
+	((listp form)
+	 (loop-add-temps (car form))
+	 (loop-add-temps (cdr form)))))
+
+(defun parse-loop-for ( &aux direction inc)
+  (declare (special *loop-form*  *loop-map-declares*  *loop-map* 
+		    *loop-body* *loop-increment* *no-declare*
+		    *loop-prologue*
+		    *loop-epilogue*
+		    *loop-end-test*
+		    *loop-bindings*
+		    ))
+  (let* ((var (loop-pop)) test incr)
+    (do ((v (loop-pop) (loop-pop)))
+	(())
+      (lcase v
+	(in (let ((lis (gensym "LIS")))
+	      (loop-add-temps var nil :in t)
+	      (loop-add-binding lis (loop-pop) nil)
+  	      (push  `(desetq ,var (car ,lis)) *loop-body*)
+	      (setf incr `(setf ,lis (cdr ,lis)))
+	      (setq test   `(null ,lis) )
+	      ))
+	(on (let ((lis
+		    (cond ((symbolp var) var)
+			  (t (gensym "LIS")))))
+	      (loop-add-temps var nil :in t)
+	      (loop-add-binding lis (loop-pop) nil)
+	      (setf incr `(setf ,lis (cdr ,lis)))
+	      (unless (eql lis var)
+		(push `(desetq ,var ,lis) *loop-body*))
+	      (setf test `(null ,lis))))
+	((upfrom from)
+	    (loop-add-binding var (loop-pop) (not(prog1 direction (setf direction 'up))) :from)
+	    (setf incr `(setf ,var ,(the-type `(+  ,var 1) :from))))
+	(downfrom
+	  (loop-add-binding var (loop-pop) (not(prog1 direction (setf direction 'down))) :from)
+	  (setf incr `(setf ,var ,(the-type `(-  ,var 1) :from))))
+	(by(setq inc (loop-pop))
+	      (cond ((and (listp inc)(eql (car inc) 'quote))
+		     (setf inc (second inc))
+		     ))
+	      (cond (direction
+		      (setf incr (subst inc 1 incr)))
+		    (t (setf incr (subst inc 'cdr incr)))))
+	(below
+	  (let ((lim (gensym "LIM")))
+	    (loop-add-binding var 0 (not(prog1 direction (setf direction 'up)))
+			      :from nil nil)
+	    (loop-add-binding lim (loop-pop) nil :from )
+	    (or incr (setf incr `(setf ,var ,(the-type `(+  ,var 1) :from))))
+	    (setq test `(>= ,var ,lim))))
+	(above
+	  (let ((lim (gensym "ABOVE")))
+	    (loop-add-binding var 0 (not(prog1 direction (setf direction 'down)))
+			      :from nil nil)
+	    (loop-add-binding lim (loop-pop) nil :from )
+	       (or incr (setf incr `(setf ,var ,(the-type `(-  ,var 1) :from))))
+	       (setq test `(<= ,var ,lim))))
+	(to
+	  (let ((lim (gensym "LIM")))
+	    (loop-add-binding var 0 (not(prog1 direction (or direction (setf direction 'up))))
+			      :from nil nil)
+	    (loop-add-binding lim (loop-pop) nil :from )
+             (or incr (setf incr `(setf ,var ,(the-type `(+  ,var 1) :from))))
+     	     (setq test `(,(if (eql direction 'down) '< '>),var ,lim))))
+	(:sloop-for (parse-loop-macro (translate-name v) :sloop-for var )
+		    (return 'done))
+        (:sloop-map (parse-loop-map (translate-name v) var ) (return nil))
+	(t(or ; (null *loop-form*)
+	      (loop-un-pop))
+	  (return 'done)
+	  )
+	))
+    
+    (let (type)
+      ;;whew maybe this is a for from type loop
+      ;;with no bound so to be safe need a fixnum bound..
+      (cond ((and direction (not *no-declare*)
+		  (not test)
+		  *type-check*
+		  (setq type (getf *automatic-declarations* :from))
+		  (progn (if (and (consp type)(eq (car type) 'type))
+			     (setf type      (second type)))
+			 (subtypep type 'fixnum)))
+             (or (constantp inc) (error "increment must be constant."))
+	     (push 
+	        (cond ((eq direction 'up)
+			  `(or (< ,var ,(- most-positive-fixnum
+					  (or inc 1)))
+			       (type-error)))
+		      (t
+		       `(or (> ,var  ,(+ most-negative-fixnum
+					  (or inc 1))))
+			       (type-error))
+		    ) *loop-increment* )
+	     )))
+    
+    (and test (push (copy-tree `(and ,test (local-finish))) *loop-end-test*))
+    (and incr (push incr *loop-increment*))
+		))
+
+(defun parse-loop-macro (v type &optional initial &aux result)
+  (declare (special *loop-form*))
+  (let ((helper (get v type)) args)
+    (setq args
+	  (ecase type
+	    (:sloop-for
+	     (let ((tem (get v :sloop-for-args)))
+	       (or (cdr tem) (error "sloop-for macro needs at least one arg"))
+	       (cdr tem)))
+	    (:sloop-macro(get v :sloop-macro-args))))
+    (let ((last-helper-apply-arg
+	    (cond ((member '&rest args) (prog1 *loop-form* (setf *loop-form* nil)))
+		  (t (dotimes (i (length args) (nreverse result))
+			     (push (car *loop-form*) result)
+			     (setf *loop-form* (cdr *loop-form*)))))))
+      (setq *loop-form*
+	    (append 
+	      (case type
+		    (:sloop-for (apply helper initial last-helper-apply-arg))
+		    (:sloop-macro(apply helper  last-helper-apply-arg)))
+	      *loop-form*)))))
+
+(defun parse-loop-map (v var)
+  (declare (special *loop-map* *loop-map-declares* *loop-form*))
+  (and *loop-map* (error "Sorry only one allowed loop-map per sloop"))
+  (let ((helper (get v :sloop-map))
+	(args  (get v :sloop-map-args)))
+    (or args (error "map needs one arg before the key word"))
+    (cond ((member '&rest args)(error "Build this in two steps if you want &rest")))
+    (let* (result
+	   (last-helper-apply-arg
+	     (dotimes (i (1- (length args)) (nreverse result))
+	       (push (car *loop-form*) result) (setf *loop-form* (cdr *loop-form*)))))
+      (setq *loop-map-declares*
+	    (do ((v (loop-pop)(loop-pop)) (result))
+		((null (l-equal v 'declare))
+		 (loop-un-pop)
+		 (and result (cons 'declare result)))
+	      (push (loop-pop) result)))
+      (setq *loop-map* (apply helper var last-helper-apply-arg))
+      nil)))
+
+(defun substitute-sloop-body (inner-body)
+  (declare (special *loop-map* *loop-map-declares*))
+    (cond (*loop-map*
+	   (setf inner-body (list  (subst (cons 'progn inner-body)
+					  :sloop-body *loop-map*)))
+	   (and *loop-map-declares*
+		(setf inner-body(subst *loop-map-declares*
+				       :sloop-map-declares inner-body)))))
+  inner-body)
+
+;;;**User Extensible Iteration Facility**
+
+(eval-when (compile eval load)
+(defun def-loop-internal (name args  body type &optional list min-args max-args
+  &aux (*print-case* :upcase) (helper (intern (format nil "~a-SLOOP-~a" name type))))
+  (and min-args (or (>= (length args) min-args)(error "need more args")))
+  (and max-args (or (<= (length args) max-args)(error "need less args")))
+ `(eval-when (load compile eval)
+    (defun ,helper ,args
+      ,@ body)
+    ,@ (and list `((pushnew ',name ,list)))
+    (setf (get ',name ,(intern (format nil "SLOOP-~a" type) (find-package 'keyword))) ',helper)
+    (setf (get ',name ,(intern (format nil "SLOOP-~a-ARGS" type)(find-package 'keyword))) ',args)))
+)
+		
+
+;;DEF-LOOP-COLLECT
+;;lets you get a handle on the collection var.
+;;exactly two args.
+;;First arg=collection-variable 
+;;Second arg=value this time thru the loop.
+(def-loop-collect sum (ans val)
+  `(initially (setq ,ans 0)
+    do (setq ,ans (+ ,ans ,val))))
+(def-loop-collect logxor (ans val)
+  `(initially (setf ,ans 0)
+  do (setf ,ans (logxor ,ans ,val))
+  declare (fixnum ,ans ,val)))
+(def-loop-collect maximize (ans val)
+  `(initially (setq ,ans nil) 
+  do (if ,ans (setf ,ans (max ,ans ,val)) (setf ,ans ,val))))
+
+(def-loop-collect minimize (ans val) 
+  `(initially (setq ,ans nil)
+  do (if ,ans (setf ,ans (min ,ans ,val)) (setf ,ans ,val))))
+
+(def-loop-collect count (ans val)
+  `(initially (setq ,ans 0)
+  do (and ,val (setf ,ans (1+ ,ans)))))
+
+(def-loop-collect thereis (ans val)(declare(ignore ans))`(do (if ,val (loop-return ,val))))
+(def-loop-collect always (ans val) `(initially (setq ,ans t) do (and (null ,val)(loop-return nil))))
+(def-loop-collect never (ans val)  `(initially (setq ,ans t) do (and  ,val  (loop-return nil))))
+ 
+
+;;DEF-LOOP-MACRO
+;;If we have done
+;(def-loop-macro averaging (x)
+;  `(sum ,x into .tot. and count t into .how-many.
+;	finally (loop-return (/ .tot. (float .how-many.)))))
+
+;(def-loop-collect average (ans val)
+;  `(initially (setf ,ans 0.0)
+;    with-unique .how-many. = 0
+;    do (setf ,ans (/  (+ (* .how-many. ,ans) ,val) (incf .how-many.)))
+;    ))
+
+;;provides averaging with current value the acutal average.
+(def-loop-macro averaging (x)
+  `(with-unique .average. = 0.0
+    and with-unique .n-to-average. = 0
+    declare (float .average. ) declare (fixnum .n-to-average.)
+    do (setf .average. (/  (+ (* .n-to-average. .average.) ,x) (incf .n-to-average.)))
+    finally (loop-return .average.)))
+
+(def-loop-macro repeat (x)
+  (let ((ind (gensym)))
+    `(for ,ind below ,x)))
+
+(def-loop-macro return (x)
+  `(do (loop-return ,x)))
+;;then we can write:
+;(sloop for x in l when (oddp x) averaging x)
+
+
+;;DEF-LOOP-FOR
+;;def-loop-for and def-loop-macro
+;;are almost identical except that the def-loop-for construct can only occur
+;;after a for:
+;(def-loop-for in-array (vars array)
+;  (let ((elt (car vars))
+;	(ind (second vars)))
+;  `(for ,ind below (length ,array) do (setf ,elt (aref ,array ,ind)))))
+;; (sloop for (elt ind) in-array ar when (oddp elt) collecting ind)
+;;You are just building something understandable by loop but minus the for.
+;;Since this is almost like a "macro", and users may want to customize their
+;;own, the comparsion of tokens uses eq, ie. you must import IN-ARRAY to your package
+;;if you define it in another one.   Actually we make a fancier in-array
+;;below which understands from, to, below, downfrom,.. and can have
+;;either (elt ind) or elt as the argument vars.
+
+;;DEF-LOOP-MAP
+;;A rather general iteration construct which allows you to map over things
+;;It can only occur after FOR.
+;;There can only be one loop-map for a given loop, so you want to only
+;;use them for complicated iterations.  
+
+(def-loop-map in-table (var table)
+  `(maphash #'(lambda ,var :sloop-map-declares :sloop-body) ,table))
+;Usage  (sloop for (key elt) in-table table
+;              declare (fixnum elt)
+;              when (oddp elt) collecting (cons key elt))
+
+
+(def-loop-map in-package (var pkg)
+  `(do-symbols (,var (find-package ,pkg))  :sloop-body))
+
+;(defun te()(sloop for sym in-package 'sloop when (fboundp sym) count t)) 
+
+;;in-array that understands from,downfrowm,to, below, above,etc.
+;;I used a do for the macro iteration to be able include it here.
+(def-loop-for in-array (vars array &rest args)
+  (let (elt ind to)
+    (cond ((listp vars) (setf elt (car vars) ind (second vars)))
+	  (t (setf elt vars ind (gensym "INDEX" ))))
+    (let ((skip (do ((v args (cddr v)) (result))
+		    (())
+		   (lcase (car v)
+		       ((from downfrom) )
+		       ((to below above) (setf to t))
+		       (by)
+		       (t (setq args (copy-list v))
+			  (return (nreverse result))))
+		   (push (car v) result) (push (second v) result))))
+      (or to (setf skip (nconc `(below (length ,array)) skip)))
+      `(for ,ind 
+	,@ skip
+	with ,elt 
+	do (setf ,elt (aref ,array ,ind)) ,@ args))))
+
+;usage: IN-ARRAY
+;(sloop for (elt i) in-array ar from 4
+;       when (oddp i)
+;       collecting elt)
+
+;(sloop for elt in-array ar below 10 by 2
+;       do (print elt))
+
+(def-loop-for = (var val)
+  (lcase (loop-peek)
+    (then (loop-pop) `(with ,var initially (desetq ,var ,val) increment (desetq ,var ,(loop-pop))))
+    (t  `(with ,var do (desetq ,var ,val)))))
+
+(def-loop-macro sloop (for-loop)
+  (lcase (car for-loop)
+    (for))
+  (let (*inner-sloop* *loop-body* *loop-map* inner-body
+	(finish-loop (gensym "FINISH"))
+	a b c e f (*loop-form* for-loop))
+    (declare (special *inner-sloop* *loop-end-test* *loop-increment*
+		      *product-for* *loop-map*
+		      *loop-form*  *loop-body*  *loop-prologue*  *loop-epilogue* *loop-end-test*
+		      *loop-bindings*
+		      ))
+    (setf *product-for* t)
+    (loop-pop)
+    (sloop-swap)
+    (parse-loop-for)
+     (sloop-swap)
+    (do ()
+	((null *loop-form*))
+      (cond ((catch 'collect  (parse-loop1)))
+	    ((null *loop-form*)(return 'done))
+	    (t ;(fsignal "hi")
+	     (print *loop-form*)
+	     (sloop-swap)
+	     (parse-loop-collect)
+	     (sloop-swap)
+	     	     (print *loop-form*)
+	     )))
+    (sloop-swap)
+    (setf inner-body (nreverse *loop-body*))
+    (and *loop-map*  (setf inner-body (substitute-sloop-body inner-body)))
+    (let ((bod
+	    `(macrolet ((local-finish () `(go ,',finish-loop)))
+	      (tagbody
+		  ,@ (nreverse *loop-prologue*)
+	          ,@ (and (null *loop-map*) '(next-loop))
+		  ,@ (nreverse *loop-end-test*)
+		  ,@ inner-body
+		  ,@ (nreverse *loop-increment*)
+		  ,@ (and (null *loop-map*) '((go next-loop)))
+		  ,finish-loop
+		  ,@ (nreverse *loop-epilogue*)))))
+      (dolist (v *loop-bindings*)
+	(setf bod
+	      `(let ,(loop-let-bindings v) ,@(and (cdr v) `(,(cons 'declare (cdr v))))
+		    ,bod)))
+      (sloop-swap)
+      `(do ,bod))))
+
+;Usage: SLOOP FOR
+;(defun te ()
+;  (sloop for i below 5
+;	 sloop (for j  to i collecting (list i j))))
+
+(def-loop-for in-carefully (var lis)
+  "Path with var in lis except lis may end with a non nil cdr" 
+  (let ((point (gensym "POINT")))
+    `(with ,point and with ,var initially (setf ,point ,lis)
+           do(desetq ,var (car ,point))
+	   end-test (and (atom ,point)(local-finish))
+	   increment (setf ,point (cdr ,point)))))
+
+;usage: IN-CAREFULLY
+;(defun te (l)
+;  (sloop for v in-carefully l collecting v))
+
+;Note the following is much like the mit for i first expr1 then expr2
+;but it is not identical, in that if expr1 refers to paralell for loop
+;it will not get the correct initialization.  But since we have such generality in the
+;our definition of a for construct, it is unlikely that all people who define
+;This is why we use a different name
+
+(def-loop-for first-use (var expr1 then expr2)
+  (or (l-equal then 'then) (error "First must be followed by then"))
+  `(with ,var initially (desetq ,var ,expr1) increment (desetq ,var ,expr2)))
+
+(defvar *collate-order* #'<)
+
+;;of course this should be a search of the list based on the
+;;order and splitting into halves.  I have one such written,
+;;but for short lists it may not be important.  It takes more space.
+(defun find-in-ordered-list
+       (it list &optional (order-function *collate-order*) &aux prev)
+  (do ((v list (cdr v)))
+      ((null v) (values prev nil))
+	 (cond ((eql (car v) it) (return (values v t)))
+	       ((funcall order-function it (car v))
+		(return (values prev nil))))
+	 (setq prev v)))
+
+(def-loop-collect collate (ans val)
+  "Collects values into a sorted list without duplicates.
+Order based order function *collate-order*"
+  `(do (multiple-value-bind
+       (after already-there )
+       (find-in-ordered-list ,val ,ans)
+       (unless already-there
+	  (cond (after (setf (cdr after) (cons ,val (cdr after))))
+		(t (setf ,ans (cons ,val ,ans))))))))
+
+;usage: COLLATE
+;(defun te ()
+;  (let ((res
+;	  (sloop for i below 10
+;            sloop (for j downfrom 8 to 0 
+;		          collate (* i (mod j (max i 1)) (random 2))))))))
+
+(defun map-fringe (fun tree)
+      (do ((v tree))
+	       (())
+	(cond ((atom v)
+		    (and v (funcall fun v))(return 'done))
+	      ((atom (car v))
+		    (funcall fun (car v)))
+	      (t (map-fringe fun (car v) )))
+	     (setf v (cdr v))))
+
+(def-loop-map in-fringe (var tree)
+  "Map over the non nil atoms in the fringe of tree"
+  `(map-fringe #'(lambda (,var) :sloop-map-declares :sloop-body) ,tree))
+
+;;usage: IN-FRINGE
+;(sloop for v in-fringe '(1 2 (3 (4 5) . 6) 8 1 2)
+;       declare (fixnum v)
+;       maximize v)
--- /dev/null
+++ acl2-6.0/interface/infix/latex-theory.lisp
@@ -0,0 +1,165 @@
+; ACL2 Version 1.9
+
+; Copyright (C) 1989-96 Computational Logic, Inc. (CLI).  All rights reserved.
+
+; Use of this software constitutes agreement with the terms of ACL2
+; license agreement, found in the file LICENSE.
+
+(in-package "user")
+
+(load-base "latex-init")
+
+;                                     INFIX-OPS
+
+; infix-ops (infix operators) should be function symbols of two or more
+; arguments for which it is desired that one symbol come out between every
+; adjacent pair of arguments.  E.g., invoking (make-infix-op plus "+") causes
+; the term (plus a b c d) to be printed as (a $+$ b $+$ c $+$ d).  Invoking
+; (make-infix-op equal "=" "\\not=") causes the term (equal x y) to be printed
+; as (x $=$ y) and it also causes the term (not (equal x y)) to be printed as
+; (x $\not= y).
+
+; Thus, for example, if one introduces a new function, say join, and wants to
+; print terms of the form (join x y) as (x \bigtriangledown y), cf. p. 44 of
+; the Latex manual, then one should invoke:
+
+;   (make-infix-op join "\\bigtriangledown")
+
+; from Lisp.  That is all that need be done to cause infix-file to subsequently
+; print `join' terms this way.
+
+; Note that throughout the following examples, we have used two backslashes to
+; get one because, in Common Lisp, backslash is a character for quoting other
+; characters.
+
+; Examples of make-infix-op.
+
+(make-infix-op eq             "=_{eq}" "\\not=_{eq}")
+(make-infix-op =              "=_{n}"  "\\not=_{n}")
+(make-infix-op equal          "="      "\\not=")
+(make-infix-op lessp          "<"        "\\not<")
+(make-infix-op <              "<"        "\\not<")
+(make-infix-op e0-ord-<       "\\leq_\\epsilon"    "\\not\\leq_\\epsilon")
+(make-infix-op leq            "\\leq"    "\\not\\leq")
+(make-infix-op <=             "\\leq"    "\\not\\leq")
+(make-infix-op greaterp       ">"        "\\not>")
+(make-infix-op >              ">"        "\\not>")
+(make-infix-op geq            "\\geq"    "\\not\\geq")
+(make-infix-op >=             "\\geq"    "\\not\\geq")
+(make-infix-op member         "\\in"     "\\not\\in")
+
+(make-infix-op append         " @ ")
+
+(make-infix-op implies        "\\rightarrow")
+(make-infix-op iff            "\\leftrightarrow")
+(make-infix-op /              "/")
+(make-infix-op remainder      "{\\rm\\bf{mod}}")
+(make-infix-op union          "\\cup")
+(make-infix-op +              "+")
+(make-infix-op -              "-")
+(make-infix-op *              "*")
+(make-infix-op and            "\\wedge")
+(make-infix-op or             "\\vee")
+(make-infix-op congruent      "\\cong")
+
+(defun zerop-printer (term)
+  (infix-print-term1 (list 'congruent (cadr term) 0)))
+
+(declare-fn-printer zerop (function zerop-printer))
+
+(make-infix-op intersection-theories   "\\cap")
+(make-infix-op set-difference-theories "{\\rm\\bf{less}}")
+(make-infix-op union-theories          "\\cup")
+
+
+;	UNARY-PREFIX-OPS, UNARY-SUFFIX-OPS, and UNARY-ABS-OPS
+
+; Use make-unary-prefix-op and make-unary-suffix-op only for function symbols
+; of one argument.  The string str (or *neg-str*) will be printed before or
+; after the argument.
+
+; unary-suffix-ops should be unary function symbols.
+
+; (make-unary-suffix-op foo x str) makes (foo x) print as (x $str$).
+
+; Examples of make-unary-suffix-op.
+
+(make-unary-suffix-op sub1    "-\\;1")
+(make-unary-suffix-op numberp "\\in {\\rm\\bf{N}}"        "\\not\\in {\\rm\\bf{N}}")
+(make-unary-suffix-op zerop   "\\simeq {\\tt{0}}"         "\\not\\simeq {\\tt{0}}")
+;; (make-unary-suffix-op nlistp "\\simeq {\\rm{\\bf{nil}}}" "\\not\\simeq {\\rm{\\bf{nil}}}")
+
+; unary-prefix-ops should be unary function symbols. 
+
+; (make-unary-prefix-op foo str) makes (foo x) print as ($str$ x).
+
+; Examples of make-unary-prefix-op.
+
+(make-unary-prefix-op 1+    "1\\;+")
+(make-unary-prefix-op minus "-")
+
+; unary-abs-ops should be unary function symbols.
+
+; To create syntax like that for absolute value, use (make-unary-absolute-op
+; lhs-str rhs-str), where lhs-str and rhs-str are the strings to print on the
+; left and right of the argument.  (make-unary-abs-op foo str1 str2) makes (foo
+; x) print as (str1 x str2).  See the example for abs below.
+
+
+;                           SOME POSSIBLE EXTENSIONS
+
+(defun simple-extension ()
+
+; Here are a few examples of normal mathematical notation for functions not in
+; the bootstrap.  Invoke this function to put these into effect.
+
+  (make-unary-abs-op    abs        "\\mid" "\\mid")
+
+  (make-unary-suffix-op fact       "{\\rm{!}}")
+
+
+  (make-infix-op        subsetp     "\\subset"         "\\not\\subset")
+  (make-infix-op        intersect   "\\cap"))
+ 
+(defun dmg-syntax ()
+
+; Here are some examples once tentatively proposed by David Goldschlag for his
+; work.  Invoke this function to put these into effect.
+
+; prefix-multiple-op's should be function symbols that take as many arguments as
+; make-prefix-multiple-op is given arguments.  (make-prefix-multiple-op foo str1
+; str2) makes (foo x y) print as ($str1$ x $str2$ y).  That is, the first string
+; comes first.
+
+  (make-prefix-multiple-op invariant         "\\Box"           "{\\rm\\bf{in}}")
+  (make-prefix-multiple-op eventually-stable "\\Diamond\\Box"  "{\\rm\\bf{in}}")
+
+; infix-multiple-op's should be function symbols that take one more argument
+; than make-infix-multiple-op is given arguments.  (make-infix-multiple-op foo
+; str1 str2) makes (foo x y z) print as (x $str1$ y $str2$ z).  That is, the
+; strings are placed between adjacent arguments.
+
+  (make-infix-multiple-op leads-to       "\\mapsto"              "{\\rm\\bf{in}}")
+  (make-infix-multiple-op unless         "{\\rm\\bf{unless}}"    "{\\rm\\bf{in}}")
+  (make-infix-multiple-op ensures        "{\\rm\\bf{ensures}}"   "{\\rm\\bf{in}}")
+  (make-infix-multiple-op e-ensures      "\,${\\rm\\bf{e-ensures}}$\," "{\\rm\\bf{for}}"
+                          "{\\rm\\bf{in}}")
+  (make-infix-multiple-op n              "\\leadsto"             "{\\rm\\bf{by}}")
+  (make-infix-multiple-op initial-condition "{\\rm{\\bf{initially\\;in}}}"))
+
+; Undoing.  To cause applications of a function symbol fn to be printed in the
+; default way, i.e., fn(x, y), invoke (clean-up 'fn).
+
+(defparameter *do-not-index-calls-of*
+  (union *do-not-index-calls-of*
+	 '(implies and or not if cond
+		   implies iff union
+		   eq = equal
+		   le < > ge leq <= geq >= lessp e0-ord-< 
+		   greaterp
+		   member append 
+		   + - * / remainder
+		   union intersection
+		   car cadr cdr cddr caddr cons consp
+		   disable force integerp member-equal null
+		   stringp symbolp true-listp alistp)))
--- /dev/null
+++ acl2-6.0/interface/infix/doinfix
@@ -0,0 +1,66 @@
+#!/bin/csh
+
+# Usage:  doinfix sample.lisp scribe
+#      :  doinfix sample.lisp latex
+#      :  doinfix sample.lisp             { defaults to sample or Scribe }
+# If you want the default mode to be LATEX then set DMODE
+# in this file.
+
+# My apologies for this ugly script.  Surely there's
+# a better way to do this.
+
+if (${#argv} == 0) then
+ echo 'usage: "doinfix file [mode]"'
+ exit
+endif
+
+set DIR = /slocal/src/acl2/v1-8/interface/infix
+set DMODE = "scribe"
+set FILE = ${argv[1]}
+set ROOT = $FILE:r
+set THEORY = $ROOT-theory.lisp
+
+if (${#argv} == 1) then
+ if ( -f $THEORY ) then 
+  set MODE=$ROOT
+ else
+  set MODE=$DMODE
+ endif
+else
+ set MODE=${argv[2]}
+endif
+
+# Want LOG to be written in the current directory.
+set LOG  = $ROOT:t.$MODE.log
+
+rm -f workxxx
+echo ':q' > workxxx
+echo '(in-package "user")' >> workxxx
+echo -n '(load "' >> workxxx
+echo -n $DIR >> workxxx
+echo '/infix")' >> workxxx
+echo -n '(infix-file "' >> workxxx
+echo -n $FILE >> workxxx
+echo -n '" :mode "' >> workxxx
+echo -n ${MODE} >> workxxx
+echo '")' >> workxxx
+
+acl2 < workxxx > $LOG
+
+if (${MODE} == "scribe") then
+ scribe $ROOT.mss >> $LOG
+else
+ if (${MODE} == "latex") then
+  latex $ROOT >> $LOG
+else
+ if (-f $ROOT.mss ) then
+  scribe $ROOT.mss >> $LOG
+else
+ if (-f $ROOT.tex ) then
+  latex $ROOT >> $LOG
+endif
+endif
+endif
+endif
+
+echo "See log file, $LOG." 
--- /dev/null
+++ acl2-6.0/interface/infix/scribe-theory.lisp
@@ -0,0 +1,186 @@
+; ACL2 Version 1.9
+
+; Copyright (C) 1989-96 Computational Logic, Inc. (CLI).  All rights reserved.
+
+; Use of this software constitutes agreement with the terms of ACL2
+; license agreement, found in the file LICENSE.
+
+(in-package "user")
+
+;; The init file should be compiled.
+(load-base "scribe-init")
+
+(defun nth-printer (term)
+  (let ((n (cadr term))
+	(expr (caddr term)))
+    (infix-print-term1 expr)
+    (pprinc "@-{")
+    (infix-print-term1 n)
+    (pprinc "}")))
+
+(declare-fn-printer nth (function nth-printer))
+
+(defun list-printer (term)
+  (pprinc "[")
+  (infix-print-l (cdr term))
+  (pprinc "]"))
+
+(declare-fn-printer list (function list-printer))
+
+
+
+;                                     INFIX-OPS
+
+; infix-ops (infix operators) should be function symbols of two or more
+; arguments for which it is desired that one symbol come out between every
+; adjacent pair of arguments.  E.g., invoking (make-infix-op plus "+") causes
+; the term (plus a b c d) to be printed as (a + b + c + d).  Invoking
+; (make-infix-op equal "=" "@neq") causes the term (equal x y) to be printed
+; as (x = y) and it also causes the term (not (equal x y)) to be printed as
+; (x @neq y).
+
+; Thus, for example, if one introduces a new function, say join, and wants to
+; print terms of the form (join x y) as (x @delta y):
+
+;   (make-infix-op join "@delta")
+
+; from Lisp.  That is all that need be done to cause infix-file to subsequently
+; print `join' terms this way.
+
+; Note that throughout the following examples, we have used two backslashes to
+; get one because, in Common Lisp, backslash is a character for quoting other
+; characters.
+
+; Examples of make-infix-op.
+
+(make-infix-op eq             "@eq@-{eq}" "@neq@-{eq}")
+(make-infix-op =              "@eq@-{n}"  "@neq@-{n}")
+(make-infix-op equal          "@eq" "@neq")
+(make-infix-op lessp          "@lt")
+(make-infix-op <              "@lt")
+(make-infix-op e0-ord-<       "@lt@-{@g(e)}")
+(make-infix-op leq            "@lte")
+(make-infix-op <=             "@lte")
+(make-infix-op greaterp       "@gt" )
+(make-infix-op >              "@gt" )
+(make-infix-op geq            "@gte")
+(make-infix-op >=             "@gte")
+(make-infix-op member         "@in" "@notin")
+
+(make-infix-op append         "@@")
+
+(make-infix-op implies        "@rightarrow")
+(make-infix-op iff            "@iff")
+(make-infix-op /              "@div")
+
+;; Use sinfix def
+(make-infix-op remainder      "@b{mod}")
+(make-infix-op union          "@union")
+(make-infix-op +              "@add")
+(make-infix-op -              "@sub")
+(make-infix-op *              "@mult")
+(make-infix-op and            "@and")
+(make-infix-op or             "@or")
+(make-infix-op congruent      "@congruent")
+
+(defun zerop-printer (term)
+  (infix-print-term1 (list 'congruent (cadr term) 0)))
+
+(declare-fn-printer zerop (function zerop-printer))
+
+(make-infix-op intersection-theories   "@inter")
+(make-infix-op set-difference-theories "@i{less}")
+(make-infix-op union-theories          "@union")
+
+
+;             UNARY-PREFIX-OPS, UNARY-SUFFIX-OPS, and UNARY-ABS-OPS
+
+; Use make-unary-prefix-op and make-unary-suffix-op only for function symbols
+; of one argument.  The string str (or *neg-str*) will be printed before or
+; after the argument.
+
+; unary-suffix-ops should be unary function symbols.
+
+; (make-unary-suffix-op foo x str) makes (foo x) print as (x @math{str}).
+
+; Examples of make-unary-suffix-op.
+
+(make-unary-suffix-op 1-      " @sub 1")
+(make-unary-suffix-op numberp "@in @b{N}"        "@notin @b{N}")
+(make-unary-suffix-op zerop   "@congruent @  @t{0}")
+;; (make-unary-suffix-op nlistp  "@approx @b{nil}"  "@not @approx @b{nil}")
+
+; unary-prefix-ops should be unary function symbols. 
+
+; (make-unary-prefix-op foo str) makes (foo x) print as ($str$ x).
+
+; Examples of make-unary-prefix-op.
+
+(make-unary-prefix-op 1+    "1 @add ")
+(make-unary-prefix-op minus   "@sub ")
+
+; unary-abs-ops should be unary function symbols.
+
+; To create syntax like that for absolute value, use (make-unary-absolute-op
+; lhs-str rhs-str), where lhs-str and rhs-str are the strings to print on the
+; left and right of the argument.  (make-unary-abs-op foo str1 str2) makes (foo
+; x) print as (str1 x str2).  See the example for abs below.
+
+
+;                           SOME POSSIBLE EXTENSIONS
+
+
+(defun simple-extension ()
+
+; Here are a few examples of normal mathematical notation for functions not in
+; the bootstrap.  Invoke this function to put these into effect.
+
+  (make-unary-abs-op    abs         "@abs<" ">")
+  (make-unary-suffix-op fact        "@r{!}")
+  (make-infix-op        subsetp     "@subset")
+  (make-infix-op        intersect   "@inter"))
+  
+
+(defun dmg-syntax ()
+
+; Here are some examples once tentatively proposed by David Goldschlag for his
+; work.  Invoke this function to put these into effect.
+
+; prefix-multiple-op's should be function symbols that take as many arguments as
+; make-prefix-multiple-op is given arguments.  (make-prefix-multiple-op foo str1
+; str2) makes (foo x y) print as ($str1$ x $str2$ y).  That is, the first string
+; comes first.
+
+  (make-prefix-multiple-op invariant         "@box(@ )"          "@b{in}")
+  (make-prefix-multiple-op eventually-stable "@lozenge@box(@ )"  "@b{in}")
+
+; infix-multiple-op's should be function symbols that take one more argument
+; than make-infix-multiple-op is given arguments.  (make-infix-multiple-op foo
+; str1 str2) makes (foo x y z) print as (x $str1$ y $str2$ z).  That is, the
+; strings are placed between adjacent arguments.
+
+  (make-infix-multiple-op leads-to       "@pari"         "@b{in}")
+  (make-infix-multiple-op unless         "@b{unless}"    "@b{in}")
+  (make-infix-multiple-op ensures        "@b{ensures}"   "@b{in}")
+  (make-infix-multiple-op e-ensures      "@ @b{e-ensures}@ " "@b{for}" "@b{in}")
+  ; (make-infix-multiple-op n              "\\leadsto"             "{\\rm\\bf{by}}")
+  (make-infix-multiple-op initial-condition "@b{initially@quad in}"))
+
+; Undoing.  To cause applications of a function symbol fn to be printed in the
+; default way, i.e., fn(x, y), invoke (clean-up 'fn).
+
+(defparameter *do-not-index-calls-of*
+  (union *do-not-index-calls-of*
+	 '(implies and or not if cond
+		   implies iff union
+		   eq = equal
+		   le < > ge leq <= geq >= lessp e0-ord-< 
+		   greaterp
+		   member append 
+		   + - * / remainder
+		   union intersection
+		   car cadr cdr cddr caddr cons consp
+		   disable force integerp member-equal null
+		   strinp symbolp true-listp alistp)))
+
+
--- /dev/null
+++ acl2-6.0/interface/infix/infix.lisp
@@ -0,0 +1,5935 @@
+; ACL2 Version 1.9
+
+; Copyright (C) 1989-96 Computational Logic, Inc. (CLI).  All rights reserved.
+
+; Use of this software constitutes agreement with the terms of ACL2
+; license agreement, found in the file LICENSE.
+
+; NOTE: we depend on the following externally defined package:
+
+(in-package "USER")
+
+;; MAJOR MODS
+
+;; 1. Added ACL2 ~ formatting conventions in doc strings and comments.
+;;    BUT THEY ONLY APPLY IF THIS FILE IS LOADED INTO ACL2.
+;;    And the following may be used to disable it.
+;;    *acl2-format-comments* => nil,  *acl2-format-doc-strings* => nil.
+;;    Ignored in lisp.
+;;    We handle doc strings by calling an ACL2 function
+;;    that takes a doc string and 2 tables and returns
+;;    a doc string, with the ACL2 formatting done.  
+;;    In order to handle arbitrary formatting within doc strings `~id[x]` 
+;;    will eventually map to `x`.  Thus, in scribe mode, ~id[@section](Testing) 
+;;    will come out as @section(Testing).
+;;    Whereas @section(Testing) would come out as @@section(Testing)
+
+;; BUGS 
+
+;; 1. In comments !p(implies a b) produces different results from !p(IMPLIES a b)
+;;    Case is honored when reading comments.  !p may need to adjust case.
+;;    We could just store things redundantly under `IMPLIES' and `implies',
+;;    but then we would fail on `Implies'
+;;
+;; 2. "~ID[{\\it foo}]" does not map to "{\\it foo}".  The braces get quoted.
+;;    Matt Kaufmann may fix.  Until then, the user can either not use
+;;    any special formatting other that that provided by ! and ~, or can
+;;    turn off ACL2 formatting, by setting *acl2-format-doc-strings* and
+;;    *acl2-format-comments* to nil.  (See keyword args to INFIX-FILE and
+;;    INFIX-SETTINGS.)  With this turned off you can still use ! and whatever
+;;    native text formatting conventions you wish.
+;;
+;; 3. "!cfoo" when processed by nqftm2fmt will result in an attempt to 
+;;    eval foo.  This may break, if the user is not taking advantage of
+;;    this !c `feature'.
+
+;; Note the difference between the backslash in comments and the backslash
+;; in doc strings.  In doc strings, because they are read as strings, they
+;; need to be quoted (e.g. doubled).
+
+
+;; INTERACTIONS
+
+;; We treat comments and doc strings similarly.  The only difference is that
+;; the initial comment characters of a comment line determine the format that
+;; the comment text is imbedded in (e.g. running text, verbatim, format, etc.
+;; See COMMENT-FORMAT documentation).
+
+;; There are 3 (at least) kinds of imbedded formatting commands
+;; that can occur in comments and doc strings.  They are handled
+;; in distinct phases of processing.
+;;
+;;   1. ~ ACL2 doc string formatting commands.
+;;   2. ! Infix commands.
+;;   3.   Text formatter commands (Scribe or LaTeX)
+;;
+;; The first two effect the output of this infix processor.
+
+;; To ensure that your text formatter (type 3) commands
+;; are preserved during processing steps 1 and 2, the simplest 
+;; approach is to enclose the commands that you wish
+;; to preserve in the ~id[...] form or between ~bid[] .. ~eid[] pairs.
+;; SEE BUG 2 ABOVE.
+
+;; Comments and doc strings are preprocessed to translate their ACL2
+;; formatting commands to our target formatter.  
+;; Note that the ACL2 doc formatter goes to great lengths to make sure
+;; weird characters in the target dialect are quoted.  So if you want
+;; such things preserved, you need to use the ~id forms above.  Because
+;; we now pass comment text through the ACL2 doc formatter, you
+;; will need to treat comments as you treat doc strings.
+;; You also need ;; to be careful of occurences of "~".  If a "~" is 
+;; not followed by an ACL2 formatting command, we will complain.
+
+;; Load packages and macros we depend on.
+;; [The following comment is modified from previous versions, which said
+;; "Require must be here.".]
+;; Require probably must be here if using other than GCL.
+
+#-gcl
+(progn
+  (require "sloop" "/acl2/interface/infix/sloop")
+  (use-package "SLOOP"))
+
+;; Add space for CFUNs (compiled funs without environment) in GCL.
+
+#+gcl(eval-when (load eval compile)
+		(defun pages-allocated (type)
+		  (declare (ignore type))
+		  (multiple-value-bind 
+		   (nfree npages maxpage nppage gcs used) (system:allocated 'cfun)
+		   (declare (ignore nfree maxpage nppage gcs used))
+		   npages)))
+
+#+gcl(eval-when (load)
+		(cond
+		 ((boundp 'si::*gcl-major-version*) ;GCL 2.0 or greater
+		  (if (< (pages-allocated 'cfun) 200)  (sys:allocate 'cfun 200)))
+		 ((< (sys::allocated-pages 'cfun) 200) (sys:allocate 'cfun 200))))
+
+;; ACL2 doc string interaction.  First is for ~ directives, second
+;; for special characters.
+
+(defvar acl2-markup-table nil)
+(defvar acl2-char-subst-table nil)
+
+;; Read-keyword command uses the acl2 read to suck in keyword
+;; commands.
+
+(proclaim '(ftype (function (t) t)
+		  acl2-parse-string
+		  read-keyword-command))
+
+(defvar a-very-rare-cons nil)
+
+(defun read-keyword-form (key n)
+  "This function reads the N args for keyword command, KEY, 
+where we have used ACL2 mechanisms to compute N.  It returns a form.
+If KEY cannot be presented in keyword form, N will be NIL."
+  (cond ((null n) key)
+	((integerp n)
+	 (let (args)
+	   (sloop for i from 1 to n 
+		  do (setq args
+			   (append
+			    args
+			    (list (readx *standard-input* nil a-very-rare-cons nil)))))
+	   (cons (intern (symbol-name key)) args)))
+	(t key)))
+
+(eval-when (load eval compile)
+
+;; Set this to be the directory in which we compile this file.
+(defparameter *infix-directory* #.(namestring (truename "./")))
+
+)
+
+(defun load-base (s)
+  (load (concatenate 'string *infix-directory* s)))
+
+(eval-when (load eval)
+
+(if (find-package "acl2")
+    (progn (load-base "acl2-formatting.lisp"))
+
+    (progn (defun acl2-parse-string (doc) (cons nil doc))
+	   (defun acl2-keywordp (key) nil)
+	   (defun read-keyword-command (key) key)))
+
+)
+
+
+#|
+
+		A Conventional Syntax Pretty-Printer for ACL2
+
+		      Originially written by Rober Boyer
+                 Modified for Scribe by Michael K. Smith (2/92,8/93)
+                 Modified for ACL2   by Michael K. Smith (10/93)
+
+
+				 INTRODUCTION
+
+The functions in this file implement a pretty-printer for Acl2 events.  The
+syntax produced is conventional mathematical notation.
+
+This file is not automatically compiled or loaded when building Acl2.
+To use this printer, after compiling and loading Acl2, compile this file and
+load it, i.e., (compile-file "infix.lisp") and (load "infix").  For
+more information on installation see the README file in the directory
+containing this file.
+
+The following text is, currently, the only documentation for this facility.
+Criticism of all sorts solicited.
+
+
+				  BASIC USE
+
+The intent is to take an ACL2 events file and produce a nicely formatted
+document.  Knowing what text formatter you are targeting, you can insert text
+formatting commands into comments.  You can also request an infix
+transformation of prefix forms in comments (see documentation of function
+NQFMT2FMT.
+
+ONE NOTE OF CAUTION:  It is important that you know what text formatter you
+are targetting, since the bulk of your comments will be copied literally into
+the text input file.  It is up to you to ensure that the interaction of
+your comments with the formatting convention of choice for the various
+comment types results in legal text formatting commands.  That is, if you
+are in Scribe mode and a comment contains an email message with net addresss
+you should quote occurences of "@" as "@@".  More importantly, if you decide
+that ";\" introduces a line to be formatted as raw LaTex (the default in
+"latex" mode), you need to ensure that any occurrence of "_" or other LaTeX
+special characters on such a line results in a meaningful formatting
+command.  For simple transformations of .event files to LaTeX I suggest you
+use the default :COMMENT-FORMAT (= 'BOYER).  This causes most comments to be
+formatted within verbatim environments, which are not so picky about special
+characters.  Scribe is more forgiving of these problems because it only has
+the single special character, "@" that needs to be watched out for. (See
+`SETTINGS THAT MAY BE MODIFIED IN MODE-THEORY.LISP'.)
+
+There are two basic modes, "latex" and "scribe".  You can then build on top of
+these to customize the printing of functions in your theory.  All mode
+sensitivity should be contained in the file <mode>-theory.lisp.  Normally this
+file also loads a basic file called <mode>-init.lisp.  The idea is that the
+`-init' files contain the minimal required information for INFIX to do its job
+with respect to a particular text formatter.  The `-theory' file contains the
+details of how you want the functions in your theory to be printed.
+`Scribe-theory.lisp' and `latex-theory.lisp' load `scribe-init.lisp' and
+`latex-init.lisp', respectively.
+
+In order to customize printing for a particular file of events, say
+"clock.events", we suggest the following approach.  Each column shows the
+procedure for the corresponding text formatter, Latex or Scribe.
+
+First, assume we have a file "clock.events", in proper syntactic form for
+acceptance by LD.  That is to say, suppose that the file
+"clock.events" contains only legal event commands such as defun's and
+defthm's, Lisp style comments, and the few other sorts of miscellaneous
+instructions documented as legal instructions to LD.
+
+
+1. Create clock-theory.lisp.  It should have the following form:
+
+-    Tex                                 Scribe
+-    ----------------------------------------------------------------
+-    (load-base "latex-theory.lisp")     (load-base "scribe-theory.lisp")
+-     ... 
+-     Your extensions and/or redefinitions.  
+-     See in particular the documentation on make-infix et.al.
+-     under `SIX GENERAL OPERATOR SCHEMAS', and the examples at the
+-     end of this file and in scribe-theory.lisp and latex-theory.lisp.
+-     ...
+-     INFIX-SETTINGS provides some simple control over an assortment of 
+-     formatting options.  See `SETTINGS THAT MAY BE MODIFIED IN MODE-THEORY.LISP'. 
+-     ...
+-    (infix-settings :mode "clock"       (infix-settings :mode "clock" 
+-               :extension "tex" ...)               :extension "mss" ...)
+
+2. Save clock-theory.lisp, preferably in the same directory with clock.events.
+
+3. Call infix-file.  The simplest call on infix-file would be just
+
+-    (infix-file "clock").
+
+   which will result in the file "clock.tex" or "clock.mss" 
+
+4. Run the appropriate formatter.
+
+5. Special considerations for latex vs. scribe.
+   
+-  To get an index in LaTeX.             To avoid an index in Scribe
+-  ----------------------------------------------------------------
+-  %latex clock                          Insert @disable(Index) in clock.mss.
+-  %makeindex clock
+-  %latex clock
+
+
+A full blown call to infix-file includes a file root and keyword arguments.
+Below is such a call with keywords supplied with their defaults.
+
+-  (infix-file fl :print-case :downcase :mode nil :chars-wide 77 :comment t)
+-
+-   :print-case - must be one of :downcase, :upcase, or :capitalize.
+-                 DEFAULT: :downcase.
+-
+-   :mode       - if not provided (thus defaulting to nil) we look for
+-                 "fl-theory.lisp" and load it if present.  If not, we use 
+-                 the mode of the last successful call to infix-file or 
+-                 query whether you want to use Scribe or Latex mode.
+-                 In this last case you will need to know where the basic
+-                 theory files are located.  Simplest is to create a trivial
+-                 -theory file in the same directory as the event files that 
+-                 just loads appropriate scribe or latex -theory file.
+-                 DEFAULT: fl root name.  If not found, queries the user.
+-
+-   :chars-wide - approximate width in characters of the formatted output.
+-                 Controls where infix inserts line breaks within expressions.
+-                 DEFAULT: 77.
+-
+-   :comment    - If t, then certain specially marked Acl2 expressions in 
+-                 comments are replaced with their conventional notation.  
+-                 See the documentation of the function `nqfmt2fmt' below for 
+-                 a description of the special syntax for this replacement 
+-                 process.  We assume you use this feature.  If not,
+-                 set *nq-default* to NIL in your mode file.
+-                 DEFAULT: T.
+
+
+			       COMMENT HANDLING
+
+- Jul 28 93 MKS - Extended comment handling.  
+- Aug  3 93 MKS - Still haven't done anything with internal comments.
+
+Modified Treatment of comments: `infix-file' preserves comments
+between events, but skips over comments within events.  We completely
+skip comments within events because we have not figured out how to
+place them appropriately mechanically.  Documentations strings in
+events are handled, normally by pulling them out of the event and
+inserting them before the event itself.
+
+Comments are formatted in several ways, depending on the character immediately
+following the semi-colon or OPEN-BAR-COMMENT.  A comment may be turned into:
+
+- 1. Running TEXT.  The comment chars (see definition following) are
+- eliminated and the text is copied to the output file.
+- 
+- 2. A FORMATted environment.  The comment chars (see definition
+- following) are eliminated, line breaks and spaces are preserved, and
+- the font is the default document font.
+- 
+- 3. A VERBATIM environment. The comment chars may or may not be preserved, 
+- line breaks and spaces are PRESERVED and the font is a fixed width font.
+- 
+- 4. An EMPHASIS environment. Like format, but the font is italic.
+
+This set, which is used by the named formats in *comment-format-alist*, can
+be extended by modifying the value of *comment-environment-mapping* in your
+theory file.
+
+To replace the comment format conventions, use (define-comment-format name
+format).
+
+The format argument has two parts, one for semi-colon comments
+and the other for #| ... |# comments.  The assignment below corresponds to
+Boyer's initial setting.
+
+- (define-comment-format 'boyer
+-   '((#\; (("\\"   nil   text)) nil verbatim #\;)
+-     (#\# (("\\"   nil   text))   t verbatim )))
+
+The structure of each of these lists is
+-  type      ::= (label (substring*) spaces-p format [char])
+-  substring ::= (string spaces-p format [char])
+
+LABEL indicates which of the two types of comments we are looking at, either
+those that start with a SEMI-COLON or those that start with LB VERTICAL-BAR.
+We determine what to do in the various cases (which amounts to choosing
+SPACES-P, FORMAT, and CHAR) based on whether the comment type indicated by
+LABEL is followed by any of the strings that begin SUBSTRINGS or not.  If it
+matches, we use the components of the matching substring, otherwise we use
+the default for the comment type, i.e.  the elements of the type list.
+
+-  If SPACES-P, consume one space if there is one.
+-  Begin formatting according to FORMAT.
+-  Insert CHAR.
+
+So, for the example above, the first sublist, whose car is the semi-colon
+character, describes how to format comments that begin with a semi-colon followed
+by specific strings.  There are two possibilites.  If the semi-colon is not
+followed by a back-slash (\), we don't look for a space, we ensure we are in a
+verbatim environment, and print a semi-colon.  If semi-colon is followed by a
+back-slash, we don't look for a space and ensure that we are in a text environment.
+
+Thus, if we encounter a comment beginning ";\", the comment should be
+inserted as top level text with no special formatting.  The ";\" will not show
+up in the output.
+
+
+- COMMENT TRANSFORMATIONS:
+
+There are three versions.  One reflects MKSmith's preferences, one Boyer's,
+and one the Common Lisp defaults.  MKSmiths is the default.  To get Boyer's,
+do (setup-comment-format 'boyer).  To get Common Lisp's, do
+(setup-comment-format 'cl).  You can insert this form in your theory file.
+To create your own conventions, see DEFINE-COMMENT-FORMAT.  
+
+- Description:
+
+-  BT begins running text, with no environment modifiers.  
+-  BF ... EF corresponds  to <begin-format> ... <end-format>
+-  BV ... EV corresponds  to <begin-verbatim> ... <end-verbatim> 
+-  BE ... EE corresponds  to <begin-emphasis> ... <end-emphasis> 
+-  BS ... ES corresponds  to <begin-section-name> ... <end-section-name> 
+-  BC ... EC corresponds  to <begin-comment> ... <end-comment> 
+- 
+-              MKS           Boyer             CL
+-  
+-  #| ... |#   BT...         BV ... EV         BT...   
+-  #|\ ... |#  BT...         BT ...            BT...   
+-  #|- ... |#  BF... EF      BV- ... EV        BF... EF
+-  #|; ... |#  BV... EV      BV; ... EV        BV... BV
+-  
+-  ; ...       BT...         BV; ... EV        BE... EE
+-  ;; ...      BT...         BV;; ... EV       BF... EF
+-  ;;; ...     BV... EV      BV;;; ... EV      BT...   
+-  ;;;; ...    BV;... EV     BV;;;; ... EV     BS... ES
+
+-  ;# ...      BC... EC        
+-  ;\ ...      BT...         BT ...            BT...   
+-  ;- ...      BF... EF      BV;- ... EV       BF... EF
+-  ;+ ...      BV... EV      BV;+ ... EV       BV... EV
+-  ;! ...      BE... EE      BV;! ... EV       BE... EE
+
+-  ;;- ...     BF; ... EF    BV;;- ... EV      BF; ... EF
+-  ;;+ ...     BV; ... EV    BV;;+ ... EV      BV; ... EV
+-  ;;! ...     BE; ... EE    BV;;! ... EV      BE; ... EE
+
+
+
+				   COVERAGE
+
+The `infix-file' function should handle the entirety of the Acl2 term syntax
+checked by ld.  We DO print out the `hint' parts of events.
+
+
+
+				  MOTIVATION
+
+We hope this notation will facilitate the communication of work with Acl2 to
+those who do not happily read Lisp notation.  But we have no expectation that
+this notation will make it easier for the Acl2 user to formulate or to prove
+theorems.
+
+
+			      NO ERROR CHECKING
+
+Warning about the absence of error checking: In general, user-callable
+subroutines of Acl2 do extensive syntactic checking on their input and
+explicitly report syntactic errors.  But this pretty printer does not do such
+syntactic checking.  Rather, we assume the given input is known to be
+syntactically correct, namely as though checked by `LD'.  Failure to
+provide input in correct syntactic form can result in nasty, brutish, and
+short Lisp errors.
+
+
+			  OTHER USER-LEVEL FUNCTIONS
+
+Besides `infix-file', here are the other user-level functions supported by
+this file.
+
+(a) (print-examples) creates a stand-alone, file named
+"infix-examples.tex" or "infix-examples.mss", which is a summary of
+the syntax we print in terms of the official Acl2 syntax.  This file
+will also correctly report any user modifications made to the syntax
+by invocation of the make... functions described later.  We hope that
+users will want to include this file in reports about Acl2 use to
+make clear what syntactic conventions they are using.
+
+(b) (NQFMT2FMT "foo") copies the file "foo.lisp" to the file
+"foo.tex" or "foo.mss", but along the way, Acl2 terms preceded by an
+exclamation mark and certain alphabetic characters are replaced with
+the formatting commands for the conventional notation this printer
+generates.  For example, when in latex mode, if nqfmt2fmt encounters
+!t(gcd x (difference y x)) in a file, it will replace it with
+{\rm{gcd}}\,({\it{x\/}}, {\it{y\/}} $-$ {\it{x\/}}).  We find the
+former much easier to read in a file.  nqfmt2fmt thus permits one to
+keep Acl2 forms in files to be read and edited by humans, e.g., in
+comments in Acl2 event files.  Ordinary uses of !, e.g., uses of it
+followed by white space or punctuation characters, are, of course,
+unaltered.  
+
+Let ev  be an Acl2 event form, e.g., (defun foo (x) 3)
+    fm  be an Acl2 term, e.g., (plus x y)
+    foo be a symbol
+
+Summary:
+
+!Pfm  - Pretty print.
+!Tfm  - Pretty print but without any line breaks.  
+!Eev  - Format event.
+!Ifoo - Identity, handling special chars of formatter.
+!Qfn  - `fn'. 
+!Vfoo - Verbatim.
+
+Begin HACK ALERT
+
+!Cform - [C]ommand evaluate.  This should really be E for EVAL.
+         The form is evaled in Lisp.  This allows you to do things
+         like dynamically change the margin (*rightmost-char-number*)
+         turn indexing on (SETQ *DO-NOT-INDEX* NIL) and off
+         (SETQ *DO-NOT-INDEX* T), or even redefine a printer.
+ 
+End HACK ALERT
+
+!section(text)    - Format text as a section header.
+!subsection(text) - Format test as a subsection header.
+
+!B(text) - bold
+!S(text) - italic
+
+Detail:
+
+!Eev  - Event. Results in conventional notation for ev.
+
+!Ifoo - Identity. Results in foo, but with with formatting sensitive
+        characters quoted.
+
+!Pfm  - Pretty print.  Results in conventional mathematical notation.
+
+!Qfn  - where fn is a symbol, results in fn surrounded by single gritches,
+        after formatting sensitive characters have been quoted, e.g., !qfoo results 
+        in `foo' in TeX.  Useful for distinguishing function symbols from other 
+        words in a sentence, since function symbols appear in Roman.  
+        Mnemonic: Q -- think Quoted.
+
+!Tfm  - where fm is an Acl2 term, results in conventional mathematical
+        notation for fm, but without any line breaks.  
+        Mnemonic: T -- think Term.
+
+!Vfoo - foo is printed as is, but in typewriter font, and with special characters quoted.  
+        Mnemonic: V -- think Verbatim.
+
+! followed by anything else is left alone, along with the exclamation mark.
+
+See the comment at the beginning of the definition of nqfmt2fmt, below, for
+details on the syntax and replacements.  There is also an option to nqfmt2fmt
+for simply stripping out the !commands.
+
+(c) (infix-form fm) prints (to *standard-output*) the formatting input for the
+conventional notation for the Acl2 term fm.  `infix-form' and `infix-event' 
+can be used to generate Latex or Scribe to be inserted manually into
+papers, but we recommend the use of nqfmt2fmt, described above, for this
+purpose.
+
+(d) (infix-event ev) prints (to *standard-output*) the Latex or Scribe for the
+conventional notation for the Acl2 event ev.
+
+
+			   USER EXTENSION OF SYNTAX
+
+`infix-file' is table-driven, and it is very easy to extend in certain ways,
+e.g., to introduce a new infix operator.  See the very end of this file, at
+`USER MODIFIABLE TABLE SETUP', for examples of how to establish new syntax.
+
+Also see `SETTINGS THAT MAY BE MODIFIED IN MODE-THEORY.LISP' to see how to
+control additional features of the printing process, e.g. indexing, details of 
+comment handling, parentheses around expressions, etc.
+
+
+                          PARENTHESES and PRECEDENCE
+
+This pretty-printer does not provide a facility for the suppression of
+parentheses via the declaration of precedence for operators.  An objective in
+printing a formula is clarity.  We know of very, very few cases (e.g., + and
+*) where precedence is something on which people agree.  As a small
+contribution towards the suppression of parentheses , we do drop the outermost
+parentheses of a formula when the formula is an argument of a function that is
+being printed in the usual f(x,y) notation, with subterms separated by
+parentheses and commas.
+
+In addition, the user has two alternatives to fully parenthesized notation.  
+
+1. Eliminate them at the top level by setting *TOP-PARENS-ELIMINABLE*
+   to T.
+
+2. Eliminate them except where absolutely required (e.g. around
+   normal, prefix function arguments) by setting
+   *TOP-PARENS-ELIMINABLE-DEFAULT* to T.
+
+See the section `SETTINGS THAT MAY BE MODIFIED IN MODE-THEORY.LISP'.
+
+
+                               OTHER FORMATTERS
+
+There are some functions in this file that take advantage of similarities
+between LaTeX and Scribe.  They are marked with `WARNING: Latex/Scribe
+dependency'.  If you want to generate input to some other formatter you may
+want to take a look at these.  Not guaranteed to be complete.  In order to
+built a -init.lisp file for some other formatter make sure you look at
+`SPECIAL VARIABLES THAT MUST BE DEFINED IN MODE-INIT.LISP'.
+
+
+                            END OF COMMENTS ON USE
+
+|#
+
+#| ---------------------------------------------------------------------------------
+
+                          COMPILATION DEPENDENCIES               
+|#
+
+;; Check that we are in a compatible Acl2.
+
+;(eval-when (load eval compile)
+; (or (boundp 'infix-input-file-type)
+;     (error "~%~%infix.lisp is to be compiled and used with acl2 versions 1992 or later,~%~
+;      not stand-alone or with older versions of acl2.~%")))
+
+;; Not used.
+
+; (defun untranslate-event (form) (acl2::untranslate form nil))
+
+;; Included from Nqthm.
+
+(defun our-flatc (x)
+  (cond ((stringp x) (+ 2 (length x)))
+        ((symbolp x) (length (symbol-name x)))
+        ((integerp x) (our-flatc-number x))
+        (t (let ((*print-base* 10)
+                 (*print-pretty* nil)
+                 (*print-radix* nil)
+                 (*print-level* nil)
+                 (*print-length* nil)
+                 (*print-case* :upcase))
+             (length (format nil "~a" x))))))
+
+(defun our-flatc-number (n)
+  (cond ((< n 0) (1+ (our-flatc-number (- n))))
+        ((< n 10) 1)
+        (t (1+ (our-flatc-number (floor (/ n 10)))))))
+
+(defvar a-very-rare-cons (cons nil nil))
+
+
+#| ---------------------------------------------------------------------------------
+
+             SETTINGS THAT MAY BE MODIFIED IN MODE-THEORY.LISP. 
+
+Use INFIX-SETTINGS to set this first set of properties.
+See files latex-mode.lisp and scribe-mode.lisp for examples.
+
+The things you can control with INFIX-SETTINGS are listed below.  The first
+choice is the default, so if you are happy with the default you don't need to
+fool with the setting.  See examples after the enumeration.  These are
+all keyword arguments to INFIX-SETTINGS.
+
+1. MODE: a string naming the theory we are in.  The default is constructed
+   the the name of the events file.  If no corresponding -theory file is found,
+   query the user.
+
+2. EXTENSION: type of output file ("mss", "tex", ...)
+
+3. OP-LOCATION: ['FRONT, 'BACK]
+   Controls where operator is printed when printing on multiple lines
+   'FRONT - put operator at beginning of line (Smith's way)
+   'BACK  - put operator at end of line (Boyer's way)
+
+4. COMMENT-FORMAT: ['SMITH, 'BOYER, 'CL]
+   Chooses from one of the predefined conventions for determining from the character
+   following the comment character how to format the comment.  This interacts
+   with your use of native-mode formatting commands in comments in the .events file.
+
+   For your own control over this, use (DEFINE-COMMENT-FORMAT name format).
+   See the description of comment handling for more information.
+
+5a. FORMAT-!-IN-COMMENTS: [T, nil]
+   If true, run nqfmt2fmt over comments.
+
+5b. ACL2-FORMAT-COMMENTS: [T, nil]
+   If true, run the acl2 doc string formatting process over comments.
+
+5c. ACL2-FORMAT-DOC-STRINGS: [T, nil]
+   If true, run the acl2 doc string formatting process over doc strings.
+
+6. ELIMINATE-TOP-PARENS: boolean [T, nil]
+   Indicates whether you wish the outermost parentheses of function bodies suppressed.
+
+7. ELIMINATE-INNER-PARENS: boolean [T, nil]
+   Suppresses all precedence related parentheses.  Much cleaner output, though an 
+   expression printed with this flag=true may reconstruct oddly, depending on the 
+   reader's precedence model.  The indentation of large expressions helps somewhat.
+
+   Example: Consider the defun, 
+   (defun foo (l)
+     (and (plistp l) (and (bar l) (baz (cdr l)))))
+
+   Below is a table showing how the body (the AND) would be printed.
+
+   TOP  INNER  Printed output of body of foo
+   t    t      plistp(l) & bar(l) & baz(cdr(l))
+   t    nil    plistp(l) & (bar(l) & baz(cdr(l)))
+   nil  t      (plistp(l) & bar(l) & baz(cdr(l)))
+   nil  nil    (plistp(l) & (bar(l) & baz(cdr(l))))
+
+8. NO-INDEX: boolean [NIL, t]. If T, then no index is generated.
+
+9. NO-INDEX-CALLS: boolean [NIL, T] or list
+   If you want all function calls indexed, NIL. you do not want any function use indexed, T.
+   If you want to exclude certain function calls, provide a list of function 
+   names to be ignored.
+
+If you do not provide a keyword value pair, the settings remains unchanged.
+Thus, you really don't have to call this function.  Though typically you want
+to change the :mode if you have created a special theory extension on top of
+Scribe or Latex.
+
+The minimal call on INFIX-SETTINGS requires a mode and extension.
+
+(INFIX-SETTINGS :MODE                   "scribe"
+		:EXTENSION              "mss"   )
+	
+The maximal call, setting everything explicitly.
+The following shows infix-settings with all of the default settings as
+arguments.  The comments indicate required types of values.  `...' indicates
+settings that the user may extend with more work.
+
+(INFIX-SETTINGS :MODE                   "scribe" ; string ["scribe","latex",...]
+		:EXTENSION              "mss"    ; string ["mss","tex"]
+		:OP-LOCATION            'FRONT   ; ['FRONT,'BACK]
+		:COMMENT-FORMAT         'SMITH   ; ['SMITH,'BOYER,'CL,...]
+		:FORMAT-!-IN-COMMENTS   NIL      ; [t,nil]
+		:ACL2-FORMAT-COMMENTS   T        ; [t,nil]
+		:ACL2-FORMAT-DOC-STRINGS T       ; [t,nil]
+		:ELIMINATE-TOP-PARENS   T        ; [t,nil]
+		:ELIMINATE-INNER-PARENS T        ; [t,nil]
+		:NO-INDEX               NIL      ; [t,nil]
+		:NO-INDEX-CALLS         NIL      ; [t,nil,l]
+		)
+
+|#
+
+
+; Variable controlling handling of special formatting within comments.  See `NQFMT2FMT'.
+
+(defparameter *nq-default* t)
+
+; If *INFIX-OP-LOCATION* (:OP-LOCATION arg to INFIX-SETTINGS) is 'BACK 
+; then you get Boyer's style of printing a list of infix operators and 
+; arguments.  If 'FRONT, you get Smiths.  Smiths is the default.  
+; You can tell who last editted this file.
+
+;- BACK form is      e.g
+;-  arg1 op               foo(a,b,c) &
+;-  arg2 op               bar(a,1) &
+;-  argn                  some-long-function-name(a,b,1)
+
+;- FRONT form is       e.g
+;-     arg1                 foo(a,b,c)
+;-  op arg2               & bar(a,1)
+;-  op argn               & some-long-function-name(a,b,1)
+
+
+; Either FRONT or BACK.
+(defparameter *infix-op-location* 'front)
+
+; Extension of input file.
+(defparameter infix-input-file-type "lisp")
+
+
+#|
+             SETTINGS THAT MAY BE RESET IN MODE-THEORY.LISP. (2)
+
+The following variables do not NEED to be reset in your mode file, but they may be.
+
+|#
+
+(defparameter *top-parens-eliminable* nil)
+
+; *TOP-PARENS-ELIMINABLE-DEFAULT* is a global.  If t, then it is ALWAYS
+; assumed to be ok to omit the outermost parentheses of the expressions
+; we are about to print.  This may procudes output that cannot
+; unambiguously be parsed back into its original sexpr format. 
+
+(defparameter *top-parens-eliminable-default* nil)
+
+#|\
+
+INDEXING
+
+If you do not any index (SETQ *DO-NOT-INDEX* T).
+If you do not want occurences of functions indexed (SETQ *DO-NOT-INDEX-CALLS* T).
+If you want to exclude certain functions, add them to the list *DO-NOT-INDEX-CALLS-OF*.
+If you want no index, see comments at beginning of file. 
+
+
+DEBUGGING
+
+Setting *INFIX-TRACE* to T will provide some debugging help when testing new mode files.
+
+
+                     END OF SETTINGS FOR MODE-INIT.LISP.
+
+---------------------------------------------------------------------------------
+|#
+
+
+; ---------------------------------------------------------------------------------
+;
+;             SPECIAL VARIABLES THAT MUST BE DEFINED IN MODE-INIT.LISP.
+;
+; Use INFIX-SETTINGS to set this variable.  See Introduction.
+
+; One of NIL, "latex", "scribe", or another string.
+(defparameter *infix-mode* nil)          
+
+
+;; STRINGS BASED ON THE TARGET FORMATTER (LaTeX, Scribe, ...)
+
+;; Default extension of created files.
+(defvar *mode-extension* nil)
+
+(defparameter *standard-prelude* nil)
+(defparameter *standard-postlude* nil)
+
+(defparameter *example-prelude* nil)
+(defparameter *begin-example-table*  nil)
+(defparameter *end-example-table*  nil)
+(defparameter *example-table-size*  nil)
+(defparameter *example-postlude*  nil)
+
+;; BASIC BRACKETS AND THEIR QUOTED VERSION.
+
+(defparameter *begin*  "")
+(defparameter *end*    "")
+(defparameter *lbrace*  "")
+(defparameter *rbrace*  "")
+
+;; ENVIRONMENT BEGIN-END PAIRS
+
+(defparameter *begin-index*  "")
+(defparameter *end-index*  "")
+
+(defparameter *begin-text-env* "")
+(defparameter *end-text-env* "")
+
+(defparameter *begin-verbatim-env* "")
+(defparameter *end-verbatim-env* "")
+
+(defparameter *begin-format-env* "")
+(defparameter *end-format-env* "")
+
+(defparameter *begin-emphasis-env*  "")
+(defparameter *end-emphasis-env*  "")
+
+(defparameter *begin-comment-env*  "")
+(defparameter *end-comment-env*  "")
+
+(defparameter *begin-section-env*  "")
+(defparameter *end-section-env*  "")
+
+(defparameter *begin-subsection-env*  "")
+(defparameter *end-subsection-env*  "")
+
+(defparameter *begin-tt-env*  "")
+(defparameter *end-tt-env*    "")
+
+(defparameter *begin-string-env*  "")
+(defparameter *end-string-env*    "")
+
+(defparameter *begin-bold-env*  "")
+(defparameter *end-bold-env*    "")
+
+(defparameter *begin-italic-env*  "")
+(defparameter *end-italic-env*    "")
+
+(defparameter *begin-sc-env*  "")
+(defparameter *end-sc-env*    "")
+
+(defparameter *begin-enumerate-env*  "")
+(defparameter *end-enumerate-env*  "")
+(defparameter *begin-item*  "")
+(defparameter *end-item*  "")
+
+(defparameter *forall* "")
+(defparameter *exists* "")
+
+;; TABBING AND INDENTING ENVIRONMENT AND TAB OPERATIONS
+
+(defparameter *begin-tabbing-env*  nil)
+(defparameter *end-tabbing-env*  nil)
+(defparameter *new-tab-row*  nil)
+
+;; Needs to be redefined in <mode>-init.lisp
+;; No longer used. A LIE!
+(defmacro new-tab-row (&optional followed-by-infix-print-term)
+  (declare (ignore followed-by-infix-print-term))
+  '(pprinc *new-tab-row*))
+
+(defparameter *tab*  nil)
+
+(defparameter *column-separator* nil)
+
+; *tabs-list* is a text-formatter specific variable.  Typically of the form of a 
+; list of pairs, either (tab . n) or (lm . n), where n is the value of
+; *infix-loc* when we set tabs and margins.
+
+(defparameter *tab-list* nil)
+(defparameter *tab-stack* nil)
+
+(defparameter *set-margin* nil)
+(defparameter *pop-margin*  nil)
+(defparameter *set-tab* nil)
+
+(defparameter *default-op-tab-space* "")
+
+(defparameter *adjust-tab-before-margin* nil)
+
+;; FONTS
+
+(defparameter *function-font*  nil)
+(defparameter *neg-str* nil)
+
+;; MATH ENV AND OPERATORS
+
+(defparameter *math-format*  nil)
+(defparameter *math-begin*  nil)
+(defparameter *math-end*  nil)
+
+(defparameter *math-thick-space*  nil)
+(defparameter *math-thin-space*  nil)
+
+(defparameter *subscript*  nil)
+
+(defparameter *begin-subscript* nil)
+(defparameter *end-subscript* nil)
+
+;; MISC.
+
+(defparameter *newpage*  nil)
+
+(defparameter *comma-atsign*  nil)
+(defparameter *caret*  nil)
+
+(defparameter *dotted-pair-separator* " . ")
+(defparameter *dotted-pair-separator-newline* ". ")
+
+(defparameter *no-tab-event-trailer*  nil)
+(defparameter *print-default-event-header*  nil)
+(defparameter *print-default-lisp-header*  nil)
+
+(defparameter *print-default-command-header*  nil)
+(defparameter *no-tab-command-trailer*  nil)
+
+
+;; ACL2 RELATED.
+
+;; We conditionally apply the ACL2 formatting conventions.
+
+(defvar *acl2-format-comments* t)
+(defvar *acl2-format-doc-strings* t)
+
+
+#|\---------------------------------------------------------------------------------
+
+              FUNCTIONS THAT MUST BE DEFINED IN MODE-INIT.LISP.
+
+Signatures as passed to (proclaim '(ftype ...) ..)
+
+() -> t : function of no args, returning arbitrary type
+ 
+            begin-tabbing                end-tabbing
+            begin-normal-text            end-normal-text
+            increase-margin
+            set-margin                   pop-margin
+            get-margin                   pop-tab
+            do-tab
+            begin-flushright             end-flushright
+
+            ;; to-current-margin            ;; newline-to-current-margin    
+            ;; force-newline
+
+(t) -> t : function of one arbitray arg, returning arbitrary type
+
+            flushright
+
+
+(t) -> t : function of one optional arg, returning arbitrary type
+
+            set-tab
+
+(character) -> t : function of one character arg, returning arbitrary type
+
+            handle-special-chars
+            handle-special-chars-in-string
+            char                         { Why is this in this list? }
+
+
+---------------------------------------------------------------------------------
+
+                           IMPLEMENTATION COMMENTS
+
+The three `tables' that govern the printing are the variables:
+
+1. *atom-alist*, which governs printing of variables, numbers, T, F, and NIL.
+
+2. *fn-alist*, which governs the printing of any term that starts with a
+function symbol, including LET, COND, CASE, LIST, LIST*, and FOR.
+
+3. *event-printer-alist*, which governs the printing of events.
+
+4. *special-quoted-forms-alist*, which governs the special printing of selected 
+quoted symbols.
+
+Each table is an alist.  Each member of any of these alists is a list (symbol
+fn), where symbol is the car of a form (or in the case of a non-consp form,
+the form itself) which is about to be printed.  fn is a Common Lisp function
+of one argument which is called on the form in question to do the printing.
+For each alist, there is a default function that is returned if a symbol is
+not explicitly represented.  One such default is the function
+default-fn-printer, which is a good function to study before contemplating
+serious modifications to this file.
+
+Although adding new members to these alists, and defining corresponding
+special purpose functions, is certainly sensible and easy, there are several
+points to be made.
+
+1.  It is unlikely that there will be any call to edit `*atom-alist*' until
+and unless TRANSLATE is changed.
+
+2.  *fn-alist* can be most easily modified by the use of the macros
+make-infix-op, make-unary-prefix-op, make-unary-suffix-op,
+make-infix-multiple-op, and make-prefix-multiple-op.  See the very end of the
+file for many examples of how syntax operators can be easily established.
+
+We really do assume throughout this code that the input file has passed
+through LD, e.g., we assume that the last test in a `cond' is on T,
+the last test in a case is an `otherwise', and that the third argument to
+`defthm' is something that translate can accept.
+
+
+STANDARD OUTPUT USED
+
+Printing.  We do *all* of our printing of formulas to *standard-output*, so we
+call princ and write-char on just one argument, the thing to be printed.
+
+|#
+
+;                                   PRINTING
+
+; The setting of the *left-margin* causes only the stuff within tabbing
+; environments to be moved over.  Acl2 event forms that do not use that
+; tabbing environment should be adjusted by other means by the user if desired.
+; *left-margin* may be set before invoking infix-form or infix-event.
+
+(defparameter *left-margin* 0)
+
+; *rightmost-char-number* is bound sometimes to alter subsidiary printing
+; operations that more text needs to be printed on the same line after they
+; finish.
+
+(defparameter *rightmost-char-number* 77)
+
+; *infix-loc* is a good estimate of how far in from the left margin we
+; currently are, counting as 1 any character, or any symbol not wired in.
+
+(defparameter *infix-loc* 0)
+
+; If *testing* is t, then we are not really printing but only counting the
+; characters we would print, trying to see if a line break is necessary.
+
+(defparameter *testing* nil)
+
+(defparameter *latex-indent-number-limit* 13)
+
+; In *tabs-in* we keep track of how deep into tabs we are so that we can punt
+; if necessary.
+
+(defparameter *tabs-in* 0)
+
+(defparameter *do-not-use-tabs* nil)
+
+; We cannot place defparameters for the following three special symbols at this
+; place in the file because their initial values contain `functions' of
+; functions to be defined later.
+
+(proclaim '(special *atom-alist* *fn-alist*))
+
+(defparameter *event-printer-alist* nil)
+
+(defparameter *index-entry-max* 100)
+
+(defparameter *negative-constant-table* nil)
+
+(defparameter *negative-infix-table* nil)
+
+(defparameter *constant-ops* nil)
+
+(defparameter *infix-ops* nil)
+
+(defparameter *infix-multiple-ops* nil)
+
+(defparameter *prefix-multiple-ops* nil)
+
+(defparameter *suffix-multiple-ops* nil)
+
+(defparameter *unary-prefix-ops* nil)
+
+(defparameter *negative-unary-prefix-table* nil)
+
+(defparameter *unary-suffix-ops* nil)
+
+(defparameter *negative-unary-suffix-table* nil)
+
+(defparameter *unary-abs-ops* nil)
+
+(defparameter *tracing-advise-break* nil)
+
+(defparameter *white-space* '(#\Space #\Newline #\Tab #\Page))
+
+(defparameter *started-a-verbatim* nil)
+
+(defparameter *started-a-format* nil)
+
+(defparameter *reported-tabs* nil)
+
+;  This `secret' function symbol is used to print out integers generated by
+; readins #b, #o, or #x syntax.
+
+(defparameter *infix-radix* (make-symbol "*infix-radix*"))
+
+; One should add to this list if any other special forms are hard wired into
+; this printer.
+
+(defparameter *wired-in-infix-examples*
+  '((if x y z)
+    (cond (test1 value1) (test2 value2) (t value3))
+    (case x (key1 answer1) (key2 answer2) (otherwise default))
+;    (for x in l when (test x) collect (fn x))
+    (let ((var1 val1) (var2 val2)) form)
+    (let* ((var1 val1) (var2 val2)) form)
+    (forall (x y) (p x))
+    (exists (x y) (p x))
+    (not x)))
+
+; Severe warning on printing.  It is illegal for any function in this
+; file to do any printing except via these four printing macros:
+; pprinc, pprin1, pformat, and pwrite-char.  This may be true
+; transitively, e.g., pprinci calls pprinc.
+
+; This rule is imposed so that the `hack' of printing invisibly (see
+; *testing*) will work.  The point is that any printing operation may
+; be called many times!  But we do not want to print unless the
+; special *testing* is bound to nil!  Key fact: if *testing* is t, we
+; DO NOT print.
+
+; A very sloppy fudge factor to account for the fact that in \tt mode,
+; characters are fatter.
+
+(defparameter *tt-size* 1.3)
+
+(defparameter *do-not-index* nil)
+
+(defparameter *do-not-index-calls* nil)
+
+(defparameter *infix-comma* (make-symbol "comma"))
+
+(defparameter *infix-comma-atsign* (make-symbol "comma-atsign"))
+
+(defparameter *infix-backquote* (make-symbol "backquote"))
+
+(defparameter *do-not-index-calls-of*
+  (list *infix-radix* *infix-comma* *infix-comma-atsign* *infix-backquote*))
+
+(defvar *user-package* (find-package "user"))
+
+(eval-when (load compile eval)
+
+(defmacro pprinc (x)
+  `(or *testing* (let ((*package* *user-package*))
+		   (princ ,x))))
+
+(defmacro pprin1 (x)
+  `(or *testing* (let ((*package* *user-package*))
+		   (prin1 ,x))))
+
+(defmacro pformat (&rest x)
+  `(or *testing* (let ((*package* *user-package*))
+		   (format ,@x))))
+
+(defmacro ppformat (&rest x)
+  `(or *testing* (let ((*package* *user-package*))
+		   (format *standard-output* ,@x))))
+
+(defmacro pwrite-char (x)
+  `(or *testing* (write-char ,x)))
+
+)
+
+; It is absolutely desireable that any printing done by any function inside this
+; file, within the scope of a tabbing environment, be done with with pprinci,
+; pprin1, or print-atom IF the printing is to contribute `real', i.e.,
+; non-formatting, characters to the final output.  The optional second argument
+; specifies how many characters are being contributed, with default 1.  If
+; *testing* is t, not only do we not want to print, but we want to throw out to
+; advise-break if we have exceeded the *rightmost-char-number*.
+
+(defvar *newline-in-text* "")
+(defvar *newline-in-env*  "")
+
+(defvar *force-newline-in-text* "")
+(defvar *force-newline-in-env*  "")
+
+(defvar *prev-line-loc* nil)
+
+(defun line-return ()
+  (setq *prev-line-loc* *infix-loc*)
+  (pwrite-char #\Newline)
+  (setq *infix-loc* (get-margin)))
+
+(defun newline-in-env (&optional force) 
+  (if force (pprinc *force-newline-in-env*) (pprinc *newline-in-env*))
+  (line-return))
+
+(defun newline-in-text (&optional force) 
+  (if force (pprinc *force-newline-in-text*) (pprinc *newline-in-text*))
+  (line-return))
+
+(eval-when (load compile eval)
+
+(defmacro begin-text () `(begin-normal-text))
+
+(defmacro end-text () '(end-normal-text))
+
+(defun last-line-feed-position (x)
+  (if (stringp x) (position #\linefeed x :from-end t)))
+
+(defmacro pprinci (x &optional (i 1))
+  `(let ((x ,x)
+	 (i ,i)
+	 n)
+     (pprinc x)
+     (setq *prev-line-loc* *infix-loc*)
+     (cond ((setq n (last-line-feed-position x))
+	    (if (> (- (length x) 1) n)
+		(setq *infix-loc* (- (length x) 1 n))
+		(setq *infix-loc* (get-margin))))
+	   (t (incf *infix-loc* i)))
+     (cond ((and *testing*
+		 (> *infix-loc* *rightmost-char-number*))
+	    (throw 'advise-break t)))))
+          
+(defmacro pprin1i (x)
+  `(progn (let ((x ,x))
+            (pprin1 x)
+            (incf *infix-loc* (our-flatc x)))
+          (cond ((and *testing*
+                      (> *infix-loc* *rightmost-char-number*))
+                 (throw 'advise-break t)))))
+
+)
+
+(defun newline (&optional force)
+  (cond (*do-not-use-tabs* (pprinci " "))
+	((null *tab-stack*) (newline-in-text force))
+	(t (newline-in-env force))))
+
+(defun to-current-margin ()
+  (cond ((eql *infix-loc* (get-margin)) nil)
+	(t (newline))))
+
+(defun blankline (&optional force)
+  (cond ((and (eql *infix-loc* (get-margin))
+	      (eql *prev-line-loc* *infix-loc*)))
+	((eql *infix-loc* (get-margin)) (newline force))
+	(t (newline force) (newline force))))
+
+(defvar *default-indent-spaces* 4)
+
+
+;                    SIX GENERAL OPERATOR SCHEMAS
+
+; The following make-... macros are used to generate functions and entries for
+; the *fn-alist*.  See the end of this file for many examples of usage which can
+; be easily extended.
+
+(defun clean-up (fn)
+
+; This function is supposed to remove completely all trace of any prior establishment
+; of any syntax for the function symbol fn.
+
+  (or (symbolp fn)
+      (error (format nil "Illegal function symbol name: ~a." fn)))
+  ;; DELTA !!!!
+  (setf (get fn 'literalform) nil)
+  (sloop for lst in '(*constant-ops* *infix-ops* *unary-prefix-ops* *unary-suffix-ops* *unary-abs-ops*)
+           do  (set lst (remove fn (eval lst))))
+  (sloop for alist in '(*fn-alist* *negative-constant-table* *negative-infix-table* *negative-unary-prefix-table*
+                                     *negative-unary-suffix-table* *prefix-multiple-ops*
+				     *suffix-multiple-ops*
+                                     *infix-multiple-ops*)
+           do  (set alist (sloop for pair in (eval alist)
+                                   unless (eq fn (car pair))
+                                   collect pair))))
+
+;; Used to reinitialize during clean-up-everything
+(defparameter *save-fn-alist* nil)
+
+(defun clean-up-everything ()
+  (sloop for alist in '(*fn-alist* *negative-constant-table*
+				     *negative-infix-table* 
+				     *negative-unary-prefix-table*
+                                     *negative-unary-suffix-table*
+				     *prefix-multiple-ops*
+				     *suffix-multiple-ops*
+                                     *infix-multiple-ops*) 
+           do (progn
+                (sloop for pair in (eval alist)
+                         do (clean-up (car pair)))
+                (set alist nil)))
+  ;; Reinitialize 
+  (setq *fn-alist* *save-fn-alist*))
+                 
+(defmacro make-constant-op (name str &optional neg-str)
+  (let ((fn-name (intern (format nil "~s-constant-op-printer" name))))
+    `(progn
+       (clean-up ',name)
+       (setf (get ',name 'literalform) ,(format nil *math-format* str))
+       (defun ,fn-name
+         (term)
+         (declare (ignore term))
+	 (pprinci ,(format nil *math-format* str)))
+       (push (list ',name (function ,fn-name))
+             *fn-alist*)
+       (push ',name *constant-ops*)
+       ,(cond (neg-str `(push (list ',name ',(format nil *math-format* neg-str))
+                              *negative-constant-table*)))
+       ',name)))
+
+(defmacro make-infix-op (name str &optional neg-str)
+  (let ((fn-name (intern (format nil "~s-infix-op-printer" name))))
+    `(progn
+       (clean-up ',name)
+       (setf (get ',name 'literalform) ,(format nil *math-format* str))
+       (defun ,fn-name
+         (term)
+         (default-infix-printer
+           term
+           ,(format nil *math-format* str)))
+       (push (list ',name (function ,fn-name))
+             *fn-alist*)
+       (push ',name *infix-ops*)
+       ,(cond (neg-str `(push (list ',name ',(format nil *math-format* neg-str))
+                              *negative-infix-table*)))
+       ',name)))
+
+(defmacro make-infix-multiple-op (name &rest strs)
+  (let ((fn-name (intern (format nil "~s-infix-multiple-op-printer" name))))
+    `(progn
+       (clean-up ',name)
+       (defun ,fn-name
+         (term)
+         (default-infix-multiple-printer
+           term
+           ',(sloop for str in strs collect
+                      (format nil *math-format* str))))
+       (push (list ',name (function ,fn-name))
+             *fn-alist*)
+       (push (cons ',name ,(length strs)) *infix-multiple-ops*)
+       ',name)))
+
+(defmacro make-prefix-multiple-op (name &rest strs)
+  (let ((fn-name (intern (format nil "~s-prefix-multiple-op-printer" name))))
+    `(progn
+       (clean-up ',name)
+       (defun ,fn-name
+         (term)
+         (default-prefix-multiple-printer
+           term
+           ',(sloop for str in strs collect
+                      (format nil *math-format* str))))
+       (push (list ',name (function ,fn-name))
+             *fn-alist*)
+       (push (cons ',name ,(length strs)) *prefix-multiple-ops*)
+       ',name)))
+
+(defmacro make-suffix-multiple-op (name &rest strs)
+  (let ((fn-name (intern (format nil "~s-prefix-multiple-op-printer" name))))
+    `(progn
+       (clean-up ',name)
+       (defun ,fn-name
+         (term)
+         (default-suffix-multiple-printer
+           term
+           ',(sloop for str in strs collect
+                      (format nil *math-format* str))))
+       (push (list ',name (function ,fn-name))
+             *fn-alist*)
+       (push (cons ',name ,(length strs)) *suffix-multiple-ops*)
+       ',name)))
+                 
+(defmacro make-unary-prefix-op (name str &optional neg-str)
+  (let ((fn-name (intern (format nil "~s-unary-prefix-op-printer" name))))
+    `(progn
+       (clean-up ',name)
+       (defun ,fn-name
+         (term)
+         (default-unary-prefix-printer
+           term
+           ,(format nil *math-format* str)))
+       (push (list ',name (function ,fn-name))
+             *fn-alist*)
+       (push ',name *unary-prefix-ops*)
+       ,(cond (neg-str `(push (list ',name ',(format nil *math-format* neg-str))
+                              *negative-unary-prefix-table*)))
+       ',name)))
+
+(defmacro make-unary-suffix-op (name str &optional neg-str)
+  (let ((fn-name (intern (format nil "~s-unary-suffix-op-printer" name))))
+    `(progn
+       (clean-up ',name)
+       (defun ,fn-name
+         (term)
+         (default-unary-suffix-printer
+           term
+           ,(format nil *math-format* str)))
+       (push (list ',name (function ,fn-name))
+             *fn-alist*)
+       (push ',name *unary-suffix-ops*)
+       ,(cond (neg-str `(push (list ',name ',(format nil *math-format* neg-str))
+                              *negative-unary-suffix-table*)))
+       ',name)))
+
+(defmacro make-unary-abs-op (name lhs-str rhs-str)
+  (let ((fn-name (intern (format nil "~s-unary-abs-op-printer" name))))
+    `(progn
+       (clean-up ',name)
+       (defun ,fn-name
+         (term)
+         (default-unary-abs-printer
+           term
+           ,(concatenate 'string *math-begin* lhs-str)
+           ,(concatenate 'string rhs-str *math-end*)))
+       (push (list ',name (function ,fn-name))
+             *fn-alist*)
+       (push ',name *unary-abs-ops*)
+       ',name)))
+
+(defmacro declare-atom-printer (x v)
+  `(let ((temp (assoc ',x *atom-alist*)))
+     (if (null temp)
+         (setq *atom-alist* (cons (list ',x ,v) *atom-alist*))
+         (rplacd temp (list ,v)))))
+
+(defmacro declare-fn-printer (x v)
+  `(let ((temp (assoc ',x *fn-alist*)))
+     (if (null temp)
+         (setq *fn-alist* (cons (list ',x ,v) *fn-alist*))
+         (rplacd temp (list ,v)))))
+
+(defmacro declare-event-printer (x v)
+  `(let ((temp (assoc ',x *event-printer-alist*)))
+     (if (null temp)
+         (setq *event-printer-alist* (cons (list ',x ,v) *event-printer-alist*))
+         (rplacd temp (list ,v)))))
+
+(defmacro declare-command-printer (x v)
+  `(let ((temp (assoc ',x *event-printer-alist*)))
+     (if (null temp)
+         (setq *event-printer-alist* (cons (list ',x ,v) *event-printer-alist*))
+         (rplacd temp (list ,v)))))
+
+(defmacro def-atom-printer (x args body)
+  (let ((printer (intern (concatenate 'string (symbol-pname x) "-atom-printer"))))
+    `(let ((temp (assoc ',x *atom-alist*)))
+       (defun ,printer ,args ,body)
+       (if (null temp)
+	   (setq *atom-alist* (cons (list ',x (function ,printer)) *atom-alist*))
+         (rplacd temp (list (function ,printer)))))))
+
+(defmacro def-fn-printer (x args body)
+  (let ((printer (intern (concatenate 'string (symbol-pname x) "-fn-printer"))))
+    `(let ((temp (assoc ',x *fn-alist*)))
+       (defun ,printer ,args ,body)
+       (if (null temp)
+	   (setq *fn-alist* (cons (list ',x (function ,printer)) *fn-alist*))
+         (rplacd temp (list (function ,printer)))))))
+
+(defmacro def-event-printer (x args body)
+  (let ((printer (intern (concatenate 'string (symbol-pname x) "-event-printer"))))
+    `(let ((temp (assoc ',x *event-printer-alist*)))
+       (defun ,printer ,args ,body)
+       (if (null temp)
+	   (setq *event-printer-alist*
+		 (cons (list ',x (function ,printer)) *event-printer-alist*))
+         (rplacd temp (list (function ,printer)))))))
+
+
+;                                    TABBING
+
+; Infix-File generates text that uses the Latex `tabbing' or Scribe `format' environment, 
+; setting a tab for each new level of indentation.  We find this a convenient
+; sublanguage to target.  
+
+; It appears based upon various experiment that perhaps Latex cannot handle tabs
+; more than about 14 deep, or so.  
+
+; The parameter, *latex-indent-number-limit*, could perhaps be increased if one 
+; had a Latex wherein this limit has been raised.  However, it is a relatively rare
+; function that needs terms that are more than 13 function calls deep.  When
+; infix-file hits this limit in Latex mode, it falls back upon the standard Acl2
+; pretty-printer, and puts the result in a verbatim environment.
+
+;; All of the following should be defined in the text-formatting init file,
+;; e.g., latex-init.lisp or scribe-init.lisp.
+
+(proclaim '(ftype (function nil t)
+                  begin-tabbing		;enter a tabbing environment
+		  begin-group-tabbing	;enter a tabbing environment, no page breaks
+                  end-tabbing		;exit tabbing env
+		  begin-normal-text	;
+		  end-normal-text
+		  increase-margin	;increment left margin by a fixed amount
+                  set-margin		;set margin to current line location
+                  pop-margin		;pop to previous margin
+                  get-margin		;value
+                  set-tab		;set at tab at current line location
+                  pop-tab		;remove a tab
+                  do-tab		;tab to next tab
+		  begin-flushright
+		  end-flushright
+                  ;; to-current-margin
+		  ;; newline-to-current-margin ;
+		  ;; force-newline
+		  ))
+
+(proclaim '(ftype (function (t) t)
+		  flushright))
+
+(proclaim '(ftype (function (&optional t) t)
+                  set-tab))
+
+(proclaim '(ftype (function (character) t)
+                  handle-special-chars
+                  handle-special-chars-in-string char))
+
+
+;                                  PRINT-ATOM
+
+; We want to slashify special characters in the following three lists in
+; case they appear in an Acl2 symbol.  Used only by print-atom and index.
+
+(defparameter doc-special-chars  nil)
+(defparameter doc-other-chars    nil)
+(defparameter doc-index-specials nil)
+
+; We also to handle the characters in doc-other-chars specially, by going into
+; math mode, since slashification with backslash does not work.
+
+(defun print-string (str &optional i)
+
+; Our own printer, which slashifies (or otherwise quotes) the doc-special-chars and
+; doc-other-chars in strings.  We print all Acl2 symbols with this
+; function and print-atom because we want to avoid generating stuff that will make 
+; the text formatter barf, e.g., in Latex, a symbol with an unslashified $, <, or { in it.
+
+  (cond ((stringp str)
+         (sloop for j below (length (the string str))
+                  for char = (char (the string str) (the fixnum j))
+                  do  (handle-special-chars-in-string char)
+                  finally (incf *infix-loc* (or i (length str)))))
+        ((symbolp str)
+         (print-atom str i))
+	((characterp str) (print-character str i))
+        (t (pprin1i str)))
+  (cond ((and *testing*
+              (> *infix-loc* *rightmost-char-number*))
+         (throw 'advise-break t))))
+
+(defun print-atom (atm &optional i)
+
+; Our own atom printer, which slashifies (or otherwise quotes) the doc-special-chars and
+; doc-other-chars in symbols and strings.  We print all Acl2 symbols with this
+; function because we want to avoid generating stuff that will make the text formatter barf,
+; e.g., in Latex, a symbol with an unslashified $, <, or { in it.
+; If i is present is is meant to be the actual printed width of the formatted output, e.g.
+; stripped of formatting commands.
+
+  (cond ((symbolp atm)
+	 (if (keywordp atm)
+	     (pprinc ":"))
+         (sloop with str = (symbol-name atm)
+                  for j below (length (symbol-name (the symbol atm)))
+                  for char = (char (the string str) (the fixnum j))
+                  do  (handle-special-chars char)
+                  finally (incf *infix-loc* (or i (length str)))))
+        ((stringp atm)
+         (incf *infix-loc* (or i (+ 4 (* 2 (length atm)))))
+         (pprinc *begin-string-env*)	;was *begin-tt-env*
+         (pprinc "\"")
+         (sloop for i below (length atm)
+                  for char = (char (the string atm) (the fixnum i))
+                  do  (handle-special-chars-in-string char))
+         (pprinc "\"")
+         (pprinc *end-string-env*))
+        (t (pprin1i atm)))
+  (cond ((and *testing*
+              (> *infix-loc* *rightmost-char-number*))
+         (throw 'advise-break t))))
+
+(defun print-character (c &optional i)
+
+; Our own character printer, quotes the doc-special-chars and
+; doc-other-chars used to print characters.  We print all Acl2 characters with this
+; function because we want to avoid generating stuff that will make the text formatter barf,
+; e.g., in Latex, a symbol with an unslashified $, <, or { in it.
+; If i is present is is meant to be the actual printed width of the formatted output, e.g.
+; stripped of formatting commands.
+
+  (handle-special-chars #\#)
+  (handle-special-chars #\\)
+  (handle-special-chars c)
+  (incf *infix-loc* (or i 3))
+  (cond ((and *testing*
+              (> *infix-loc* *rightmost-char-number*))
+         (throw 'advise-break t))))
+
+(defun print-atoms (l)
+  (cond ((cdr l)
+	 (sloop for x on l
+		do (cond ((cddr x)
+			  (print-atom (car x))
+			  (pprinc ", "))
+			 ((cdr x)
+			  (print-atom (car x))
+			  (pprinc " and "))			 
+			 (t (print-atom (car x))))))
+	(t (print-atom (car l)))))
+
+(defun print-bare-function-name (term)
+  (pprinc "`")
+  (print-atom term)
+  (pprinc "'"))
+
+(defun print-bare-function-names (l)
+  (cond ((cdr l)
+	 (sloop for x on l
+		do (cond ((cddr x)
+			  (print-bare-function-name (car x))
+			  (pprinc ", "))
+			 ((cdr x)
+			  (print-bare-function-name (car x))
+			  (pprinc " and "))			 
+			 (t (print-bare-function-name (car x))))))
+	(t (print-bare-function-name (car l)))))
+
+
+;                             FONT SYMBOL PRINTERS
+
+(defun bold-sym-printer (x &optional i)         ; Print in bold face.
+  (pprinc *begin-bold-env*)
+  (cond ((symbolp x) (print-atom x i))
+	((characterp x) (print-character x i)) 
+	(t (print-string x i)))
+  (pprinc *end-bold-env*))
+
+(defun italic-sym-printer (x &optional i)               ; Print in italic face.
+  (pprinc *begin-italic-env*)
+  (cond ((symbolp x)    (print-atom x i))
+	((characterp x) (print-character x i)) 
+	(t (print-string x i)))
+  (pprinc *end-italic-env*))
+
+(defun tt-sym-printer (x &optional i)           ; Print in typewriter font.
+  (pprinc *begin-tt-env*)
+  (cond ((symbolp x) (print-atom x i))
+	((characterp x) (print-character x i)) 
+	(t (print-string x i)))
+  ;; We charge more for tt characters.
+  (incf *infix-loc* (* (- *tt-size* 1) (our-flatc x)))
+  (pprinc *end-tt-env*))
+
+(defun small-caps-sym-printer (x &optional i)           ; Print in small caps.
+  (pprinc *begin-sc-env*)
+  (cond ((symbolp x) (print-atom x i))
+	((characterp x) (print-character x i)) 
+	(t (print-string x i)))
+  (pprinc *end-sc-env*))
+
+(defun font-sym-printer (symbol font)
+  (case font
+    (bold   (bold-sym-printer symbol))
+    (italic (italic-sym-printer symbol))
+    (tt     (tt-sym-printer symbol))
+    (sc     (small-caps-sym-printer symbol))
+    (otherwise (format *terminal-io* "Bad font descriptor (~a) passed to subscript printer.~%" font)
+               (tt-sym-printer symbol))))
+
+(defun subscript (x)
+  (pprinc *begin-subscript*)
+  (print-atom x)
+  (pprinc *end-subscript*))
+
+;                                   *ATOM-ALIST*
+
+; *atom-alist* is one of the three tables off of which this printer is driven.
+; It determines how a variable symbol is printed.  It is unlikely that anyone
+; would want to change this unless translate changes because t, f, and nil are
+; the only symbols that translate treats specially as constants instead of as
+; variable symbols.
+
+; We would like to put this at the beginning of the file but cannot, so we put
+; a special declaration up there.
+
+(defparameter *atom-alist*
+  (list (list 't   (function bold-sym-printer))
+        (list 'f   (function bold-sym-printer))
+        (list 'nil (function bold-sym-printer))))
+
+(defun default-atom-printer (var)
+
+; We put variables in italics, strings in typewriter.
+
+  (cond ((keywordp var) (print-atom var))
+	((symbolp var)  (italic-sym-printer var))
+        ((stringp var)  (print-atom var))
+        ((numberp var)  (tt-sym-printer var))
+	((characterp var) (print-character var))
+        (t (pprin1 var))))
+
+(defun get-atom-printer (sym)
+  (let ((a (assoc sym *atom-alist*)))
+    (cond (a (cadr a))
+          (t (function default-atom-printer)))))
+
+
+;                                     QUOTE
+
+; The printing of quote terms is intrinsically intertwined with the printing of
+; backquoted terms.  The backquoted terms have been read with our
+; special-to-infix-file backquote reader.
+
+(defun quote-printer1 (term)
+
+; How we output a quoted term.
+
+  (cond ((stringp term)                       (print-atom term))
+	((atom term)
+	 (tt-sym-printer term))
+        ((eq (car term) 'quote)
+         (quote-printer term))
+        ((eq (car term) *infix-comma*)
+         (comma-printer term))
+        ((eq (car term) *infix-comma-atsign*)
+         (comma-atsign-printer term))
+        ((eq (car term) *infix-backquote*)
+         (backquote-printer term))
+        ((eq (car term) *infix-radix*)
+         (funcall (function *infix-radix*-printer) term))
+        ((advise-break (list 'quote term))
+         (quote-printer1-advise-break term))
+        (t (quote-printer1-tt-form term))))
+
+(defun tt-pprinci (term &optional (size 1))
+  (pprinci *begin-tt-env* size)
+  (pprinci term size)
+  (pprinci *end-tt-env*))   
+
+(defun quote-printer1-tt-form (term)
+  (tt-pprinci "(" *tt-size*)
+  (sloop for tail on term do
+           (progn (quote-printer1 (car tail))
+                  (cond ((null (cdr tail)) (tt-pprinci ")" *tt-size*))
+                        ((or (atom (cdr tail))
+                             (eq (car (cdr tail)) *infix-comma*)
+                             (eq (car (cdr tail)) *infix-comma-atsign*)
+                             (eq (car (cdr tail)) *infix-backquote*))
+                         (tt-pprinci *dotted-pair-separator*  4)
+                         (quote-printer1 (cdr tail))
+                         (tt-pprinci ")" *tt-size*)
+                         (line-return))
+                        (t (tt-pprinci " " *tt-size*))))
+           until (atom (cdr tail))))
+                                
+(defun quote-printer1-advise-break (term)
+  (tt-pprinci "(" *tt-size*)
+  (set-margin)
+  ;; (let ((*left-margin-tab-context* nil)) )
+  (sloop for tail on term
+           do (progn (quote-printer1 (car tail))
+                     (cond ((null (cdr tail))
+                            (tt-pprinci ")" *tt-size*))
+                           ((or (atom (cdr tail))
+                                (eq (car (cdr tail)) *infix-comma*)
+                                (eq (car (cdr tail)) *infix-comma-atsign*)
+                                (eq (car (cdr tail)) *infix-backquote*))
+                            (to-current-margin)	;newline
+                            (tt-pprinci *dotted-pair-separator-newline* 4)
+                            (quote-printer1 (cdr tail))
+                            (tt-pprinci ")" *tt-size*)
+                            (return nil))
+                           ((and (or (atom (car tail)) (eq *infix-radix* (car (car tail))))
+                                 (cdr tail)
+                                 (or (atom (cadr tail)) (eq *infix-radix* (car (cadr tail))))
+                                 (not (advise-break (list 'quote (cadr tail)))))
+                            (tt-pprinci " " *tt-size*))
+                           (t (to-current-margin)))) ;newline
+           until (atom (cdr tail)))
+  (pop-margin))
+
+(defun pending-printer (term)
+  (declare (ignore term))
+  (italic-sym-printer "pending"))
+
+(defvar *special-quoted-forms-alist*
+  (list (cons 'pending (function pending-printer))))
+
+(defun quote-printer (term)
+  (let ((fun (cdr (assoc (cadr term) *special-quoted-forms-alist*))))
+    (if fun
+	(funcall fun (list (cadr term)))
+	(progn (tt-pprinci "'" *tt-size*)
+	       (quote-printer1 (cadr term))))))
+
+(defun backquote-printer (term)
+  (tt-pprinci "`" *tt-size*)
+  (quote-printer1 (cadr term)))
+
+(defun comma-printer (term)
+  (tt-pprinci "," *tt-size*)
+  (quote-printer1 (cadr term)))
+
+(defun comma-atsign-printer (term)
+  (tt-pprinci *comma-atsign* 4)
+  (quote-printer1 (cadr term)))
+
+
+;; NEED to have read, read in the user package, where all of our
+;; variables are compiled!.  So use readx.
+
+(defun readx (str a b c)
+  (let ((*package* *user-package*))
+    (let ((val (read str a b c)))
+      (if (acl2-keywordp val)
+	  (read-keyword-command val)
+	  val))))
+
+(defun read-from-stringx (str)
+  (let ((*package* *user-package*))
+    (read-from-string str)))
+
+
+; We arrange to read #b, #o, and #x syntax preserving what was read and to
+; print it in the conventional notation whereby #o10 comes out as
+
+;      10
+;        8
+
+; We do this by having READ fake numbers into the parse tree looking like
+; function calls of the function whose name is the uninterned symbol that is
+; the value of *infix-radix*, and by supplying a printer for this symbol.
+
+; The 6 read macros for this syntax:
+
+(defun smash-infix-readtable ()
+  (sloop for c in '(#\B #\b #\O #\o #\X #\x)
+           as n in '(2 2 8 8 16 16)
+           for l = (case n
+                         (2 '(#\0 #\1))
+                         (8 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7))
+                         (16 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
+                               #\A #\B #\C #\D #\E #\F
+                               #\a #\b #\c #\d #\e #\f)))
+           do
+           (set-dispatch-macro-character
+            #\#
+            c
+            (let ((l l)
+                  (nn n)
+                  (arithmetic-signs '(#\+ #\- #\/)))
+              (function (lambda (stream char n)
+                          (declare (ignore char n))
+                          (list* *infix-radix* nn
+                                 (sloop for ch = (read-char stream)
+                                          with ll = nil
+                                          do
+                                          (cond ((or (member ch l)
+                                                     (member ch arithmetic-signs))
+                                                 (push ch ll))
+                                                (t (unread-char ch stream)
+                                                   (return (nreverse ll)))))))))))
+
+; Also setup the backquote reader.
+
+  (set-macro-character #\`
+    #'(lambda (stream char)
+       (declare (ignore char))
+       (list *infix-backquote* (readx stream t nil t))))
+  (set-macro-character #\,
+   #'(lambda (stream char)
+       (declare (ignore char))
+       (case (peek-char nil stream t nil t)
+             ((#\@ #\.)
+              (read-char stream)
+              (list *infix-comma-atsign* (readx stream t nil t)))
+             (t (list *infix-comma* (readx stream t nil t)))))))
+
+(defun *infix-radix*-printer (term)
+  (pprinc *math-begin*)
+  (pprinc *begin-tt-env*)
+  (sloop for ch in (cddr term) do (pprinc ch))
+  (pprinc *end*)
+  (pprinc *subscript*)                  ; "}_{"
+  (pprinc *begin*)
+  (pprin1i (cadr term))
+  (pprinc *end-tt-env*)
+  (pprinc *math-end*))
+
+(defun subscript-printer (symbol subscript &optional (font 'tt))
+  ;; Font must be one of bold, italic, tt, sc (small caps)
+  (pprinc *math-begin*)
+  (font-sym-printer symbol font)
+  (pprinc *subscript*)                  ; "_" in latex
+  (pprinc *begin*)
+  (font-sym-printer subscript font)
+  (pprinc *end*)
+  (pprinc *math-end*))
+
+;; FROM NQTHM
+
+(eval-when (load compile eval)
+
+(defmacro match (term pattern) (match-macro term pattern))
+
+(defun match-macro (term pat)
+  (cond ((atom term)
+         (match1-macro term pat))
+        (t (let ((sym (gensym "match")))
+             `(let ((,sym ,term))
+                ,(match1-macro sym pat))))))
+
+(defvar setq-lst nil)
+(defvar test-lst nil)
+
+(defun match1-macro (term pat)
+  (let (test-lst setq-lst)
+    (match2-macro term pat)
+    (list (quote cond)
+          (cons
+           (cond ((null test-lst) t)
+                 ((null (cdr test-lst)) (car test-lst))
+                 (t (cons (quote and) test-lst)))
+           (nconc setq-lst (list t))))))
+
+(defun match2-macro (term pat)
+  (cond ((atom pat)
+         (cond ((eq pat (quote &)) nil)
+               ((or (eq pat t) (eq pat nil))
+                (error "attempt to smash t or nil."))
+               ((symbolp pat)
+                (setq setq-lst (nconc setq-lst (list (list (quote setq) pat term)))))
+               (t (setq test-lst
+                        (nconc test-lst (list (list (quote equal) pat term)))))))
+        ((eq (quote cons) (car pat))
+         (setq test-lst (nconc test-lst (list (list (quote consp) term))))
+         (match2-macro (list (quote car) term) (cadr pat))
+         (match2-macro (list (quote cdr) term) (caddr pat)))
+        ((eq (quote quote) (car pat))
+         (cond ((symbolp (cadr pat))
+                (setq test-lst
+                      (nconc test-lst
+                              (list (list (quote eq)
+                                    (list (quote quote) (cadr pat)) term)))))
+               (t (setq test-lst (nconc test-lst
+                                         (list (list (quote equal)
+                                               (list (quote quote) (cadr pat))
+                                               term)))))))
+        (t (cond ((not (eq (quote list) (car pat)))
+                  (setq pat (cons (quote list)
+                                  (cons (list (quote quote) (car pat))
+                                        (cdr pat))))))
+           (sloop for subpat in (cdr pat) do
+                    (progn (setq test-lst
+                                 (nconc test-lst (list (list (quote consp) term))))
+                           (match2-macro (list (quote car) term) subpat)
+                           (setq term (list (quote cdr) term))))
+           (setq test-lst (nconc test-lst (list (list (quote eq) term nil)))))))
+
+)
+
+;; END NQTHM importation
+
+
+; A FEW HAND-CODED FORM PRINTERS:  IF, COND, CASE, LET, FOR, FORALL and EXISTS.
+
+(defun math-space (&optional (n 1))
+  (cond (*do-not-use-tabs* (setq n 1)))
+  (pprinc *math-begin*)
+  (sloop for i from 1 to n do
+           (pprinci *math-thick-space*))
+  (pprinc *math-end*))
+
+(defun math-thin-space (&optional (n 1))
+  (cond (*do-not-use-tabs* (setq n 1)))
+  (pprinc *math-begin*)
+  (sloop for i from 1 to n do
+           (pprinci *math-thin-space*))
+  (pprinc *math-end*))
+
+(defun condify (term)
+  (let (x u v)
+    (sloop with pairs
+             while (match term (if x u v))
+             do (progn (push (list x u) pairs)         ; ??? I put the push and setq into a PROGN ???
+                       (setq term v))
+             finally
+             (progn (push (list t term) pairs)
+                    (return (cons 'cond (reverse pairs)))))))
+
+(defun if-printer (term)
+  (cond ((null (cddr term))
+         (format *terminal-io* "~%Ill formed if-expression - ~a~%" term)
+         (cond-printer (condify (append term '(nil nil)))))
+        ((null (cdddr term))
+         (format *terminal-io* "~%Ill formed if-expression - ~a~%" term)
+         (cond-printer (condify (append term '(nil)))))
+        (t (cond-printer (condify term)))))
+
+; We take the attitude that we can print an untranslated term t as we would
+; print an untranslated term t' provided that t and t' translate to the same
+; term.  This point of view is to be found expressed in our treatment of nested
+; if's as though they were conds.
+
+(defun cond-printer (term)
+  (let (some-line-broken)
+    (advise-break-if-testing)
+    (let ((*top-parens-eliminable* t))
+      (cond ((null (cddr term))
+	     (infix-print-term1 (cadr (cadr term))))
+	    (t (let ((cases (cdr term))
+		     (first-case (car (cdr term))))
+		 (set-margin)
+		 ;; (let ((*left-margin-tab-context* nil))  )
+		 (bold-sym-printer "if " 3)
+		 (infix-print-term1 (car first-case))
+		 ;; then
+		 (cond ((let ((*rightmost-char-number* (- *rightmost-char-number* 7)))
+			  (advise-break (cadr first-case)))
+			(setq some-line-broken t)
+			(to-current-margin)) ;newline-
+		       (t (math-space 1)))
+		 (bold-sym-printer " then " 5)
+		 (infix-print-term1 (cadr first-case))
+		 ;; else
+		 (cond ((let ((*rightmost-char-number* (- *rightmost-char-number* 7)))
+			  (advise-break (cons 'cond (cdr cases))))
+			(setq some-line-broken t)
+			(to-current-margin)) ;newline-
+		       (t (math-space 1)))
+		 ;;
+		 (sloop for tail on (cdr cases) do
+                        (cond ((null (cdr tail))
+                               (bold-sym-printer " else " 5)
+                               (let ((*rightmost-char-number* (- *rightmost-char-number* 6)))
+                                 (infix-print-term1 (cadr (car tail))))
+			       ;; TESTING.  Inserted (math-space 1) and deleted the following
+			       ;; Swithced back, using to-current-margin.
+			       (if some-line-broken
+				   (to-current-margin)
+				   (math-space 1))
+                               (bold-sym-printer "fi" 3)
+			       (pop-margin))
+                              (t (bold-sym-printer " elseif " 7)
+                                 (infix-print-term1 (caar tail))
+                                 (cond ((let ((*rightmost-char-number*
+					       (- *rightmost-char-number* 7)))
+                                          (advise-break (cadar tail)))
+					(setq some-line-broken t)
+                                        (to-current-margin)) ;newline
+                                       (t (math-space 1)))
+                                 (bold-sym-printer " then " 5)
+                                 (infix-print-term1 (cadar tail))
+                                 (to-current-margin)))))))))) ;newline
+
+(defun print-one-case (case term)
+  (let ((break (advise-break term)))
+    (bold-sym-printer " case = " 7)
+    ;; Was (infix-print-term1 case)
+    (quote-printer1 case)
+    (bold-sym-printer " then " 5)
+    (if break
+	(progn (to-current-margin) (math-space 5) (set-margin))	;newline
+      (math-space 1))
+    (infix-print-term1 term)
+    (if break (pop-margin))
+    (to-current-margin)))		;newline
+
+(defun case-printer (term)
+  (advise-break-if-testing)
+  (let ((*top-parens-eliminable* t))
+    (cond ((null (cdddr term))
+           (infix-print-term1 (cadr (caddr term))))
+          (t (let ((cases (cddr term))
+                   (first-case (car (cddr term))))
+               (set-margin)
+               ;; (let ((*left-margin-tab-context* nil))   ... )
+               (bold-sym-printer "case on " 9)
+               (infix-print-term1 (cadr term))
+               (pprinci ":")
+               (to-current-margin)	;newline
+	       (pprinci "  " 2)
+               (set-margin)
+	       (print-one-case (car first-case) (cadr first-case))
+               (sloop for tail on (cdr cases) do
+		      (cond ((null (cdr tail))
+			     (bold-sym-printer " otherwise " 10)
+			     (infix-print-term1 (cadr (car tail)))
+			     (to-current-margin)
+			     ;; (math-space 1)
+			     ;; Was imbedded in
+			     ;; (let((*rightmost-char-number* (- *rightmost-char-number* 8))) 
+			     ;;    <form>)
+			     (bold-sym-printer "endcase" 8)
+			     (pop-margin))
+			    (t (print-one-case (caar tail) (cadar tail)))))
+	       (pop-margin))))))
+
+(defun let-printer (term)
+  (advise-break-if-testing)
+  (let ((*top-parens-eliminable* t))
+    (cond ((null (cadr term))
+           (infix-print-term1 (caddr term)))
+          (t (let ((lets (cadr term)))
+               (set-margin)
+               ;; (let ((*left-margin-tab-context* nil)) .. )
+               (bold-sym-printer "let " 5)
+               (set-margin)
+	       ;; Symbolp lets => lets = NIL.  Deleted (infix-print-term1 lets))
+               (if (consp lets)
+		   (sloop for tail on lets
+			  for let = (car tail)
+			  do (progn (infix-print-term1 (car let))
+				    (bold-sym-printer " be " 3)
+				    (infix-print-term1 (cadr let))
+				    (cond ((cdr tail)
+					   (pprinci ", " 1)
+					   (to-current-margin))
+					  (t (to-current-margin)
+					     (bold-sym-printer " in " 3)))))) 
+	       ;; Deleted (to-current-margin) after printing " in "
+	       (pop-margin)
+	       (to-current-margin)
+               (let ((*rightmost-char-number* (- *rightmost-char-number* 7)))
+                 (infix-print-term1 (caddr term)))
+               (pop-margin))))))
+
+(defun let*-printer (term)
+  (advise-break-if-testing)
+  (let ((*top-parens-eliminable* t))
+    (cond ((null (cadr term))
+           (infix-print-term1 (caddr term)))
+          (t (let ((lets (cadr term)))
+               (set-margin)
+               ;; (let ((*left-margin-tab-context* nil)) .. )
+               (bold-sym-printer "let* " 5)
+               (set-margin)
+               (if (consp lets)
+		   (sloop for tail on lets
+			  for let = (car tail)
+			  do (progn (infix-print-term1 (car let))
+				    (bold-sym-printer " be " 3)
+				    (infix-print-term1 (cadr let))
+				    (cond ((cdr tail)
+					   (pprinci ", " 1)
+					   (to-current-margin)) ;newline
+					  (t (to-current-margin)
+					     (bold-sym-printer " in " 3)))
+				    )))
+	       (pop-margin)
+	       (to-current-margin)
+               (let ((*rightmost-char-number* (- *rightmost-char-number* 7)))
+                 (infix-print-term1 (caddr term)))
+               (pop-margin))))))
+
+(defun mv-printer (term)
+  (mv-printer1 (cdr term)))
+
+(defparameter *mv-bracket-left* "")
+(defparameter *mv-bracket-right* "")
+
+(defun mv-printer1 (vars)
+  (pprinc *mv-bracket-left*)
+  (sloop for tail on vars do
+	 (progn
+	   (if (symbolp (car tail))
+	       (funcall (get-atom-printer (car tail)) (car tail))
+	       (infix-print-term1 (car tail)))
+	   (if (cdr tail) (pprinci ", " *tt-size*))))
+  (pprinc *mv-bracket-right*))
+
+(defun assign-printer (vars term)
+  (cond ((atom vars)
+	 (funcall (get-atom-printer vars) vars))
+	(t (mv-printer1 vars)))
+  (math-space 1)
+  (pprinc ":=")
+  (math-space 1)
+  (infix-print-term1 term)
+  (pprinc ";"))
+
+(defun mv-let-printer (term)
+  ;; (mv-let (arg1 ... argn) form form)
+  (advise-break-if-testing)
+  (let ((*top-parens-eliminable* t)
+	(vars (cadr term))
+	(value (caddr term))
+	(form (cadddr term)))
+    (set-margin)
+    (assign-printer vars value)
+    ;; newline(to-current-margin)
+    (to-current-margin)
+    (infix-print-term form)
+    (pop-margin)))
+
+(defun make-alist-pairlist (l)
+  (if (not (consp l))
+      l
+      (cons (list (caar l) (cdar l))
+            (make-alist-pairlist (cdr l)))))
+
+
+;                                   *FN-ALIST*
+
+; *fn-alist* is considerably extended via calls to make-... at the end of this
+; file.  This initial value given here picks up the very few entries for which
+; we have totally ad hoc handling.  Although LIST and LIST* are essentially
+; macros, we handle them by the default-fn-printer, since they evaluate all
+; their arguments.  We could have handled IF this default way, too.  It was
+; essential that we handle QUOTE, COND, CASE, LET, and FOR specially because
+; they do not evaluate all their arguments but `parse' them to some extent.
+
+; We would like to put this at the top but have to put it after the functions
+; are defined.
+
+(defparameter *fn-alist*
+  (list (list 'quote (function quote-printer))
+        (list *infix-backquote* (function backquote-printer))
+        (list *infix-radix* (function *infix-radix*-printer))
+        (list 'if    (function if-printer))
+        (list 'let   (function let-printer))
+        (list 'let*  (function let*-printer))
+        (list 'mv     (function mv-printer))
+        (list 'mv-let (function mv-let-printer))
+        (list 'cond  (function cond-printer))
+        (list 'case  (function case-printer))))
+
+(defun default-fn-printer (term)
+
+; This function is a good function to study if one finds it necessary to define
+; by hand a special handler for a function symbol.  We annotate rather
+; verbosely as a pedagogical device.
+
+; In general, we know that term is a lisp object on which TRANSLATE does not
+; cause an error.
+
+; Binding *top-parens-eliminable* is a sign to the infix, prefix, and suffix
+; operators immediately below that we are putting out syntactic noise (e.g.,
+; commas) that is so strong that they need not emit an initial outer layer of
+; parentheses.
+
+  (let ((*top-parens-eliminable* t)
+        (advice (advise-break term)))
+
+    (cond ((atom (car term))
+
+; First put out the function symbol, in roman.
+; Functions of no arguments are printed as constants, without parentheses,
+; rather than with, e.g., foo().
+
+           (cond ((null (cdr term))
+                  (roman-font (car term))
+                  (return-from default-fn-printer nil)))
+
+; We want a very tiny space in front of the open parenthesis because otherwise,
+; it looks like some function symbols touch the open parenthesis.  In some
+; cases, this results in a touch more space than we like, and perhaps there
+; exists a more delicate kerning command.
+
+           (roman-font (car term))
+           (math-thin-space)
+           (pprinci "("))
+          (t (pprinci "(")
+             (setq term (cons 'foo term))))
+    (cond ((null (cdr term))
+           (pprinci ")"))
+          ((null (cddr term))
+           (infix-print-term1 (cadr term))
+           (pprinci ")"))
+
+; The coder of the printer for each function should consider whether to print
+; flat or not, by calling advise-break.  This is a somewhat aesthetic and
+; heuristic decision.
+
+          (advice
+
+; If it is decided not to print flat, one needs somewhere early to set a tab
+; stop to which to return.
+
+           (set-margin)
+           ;; (let ((*left-margin-tab-context* nil)) .. )
+           (sloop for tail on (cdr term)
+                    do (progn (infix-print-term1 (car tail))
+                              (cond ((cdr tail)
+                                     (pprinci ",")
+                                     ;; Each call of newline-to-current-magin will
+                                     ;; return to the indent we set.
+                                     (to-current-margin)) ;newline
+                                    (t
+                                     (pprinci ")")
+                                     ;; Now we get rid of the indent.
+                                     (pop-margin))))))
+          (t (sloop for tail on (cdr term)
+		      do (progn
+			   (cond ((keywordp (car tail))
+				  (infix-print-keyword-value-pair (car tail) (cadr tail))
+				  (setq tail (cdr tail)))
+				 (t (infix-print-term1 (car tail))))
+			   (cond ((cdr tail)
+				  (pprinci ", "))
+				 (t (pprinci ")")))))))))
+
+(defun infix-print-keyword-value-pair (key value)
+  (infix-print-term1 (list 'assign (symbol-name key) value)))
+
+(defun get-fn-printer (sym)
+  (or (symbolp sym)
+      (error (format nil "Illegal object where function symbol expected : ~a." sym)))
+  (let ((a (assoc sym *fn-alist*)))
+    (cond (a (cadr a))
+          (t (function default-fn-printer)))))
+
+(defun defun-call-part-printer (term)
+  (let ((*top-parens-eliminable* t)
+        (advice (advise-break term)))
+    (cond ((atom (car term))
+
+; First put out the function symbol, in roman.
+; Functions of no arguments are printed as constants, without parentheses,
+; rather than with, e.g., foo().
+
+           (cond ((null (cdr term))
+                  (roman-font (car term))
+                  (return-from defun-call-part-printer nil)))
+
+; We want a very tiny space in front of the open parenthesis because otherwise,
+; it looks like some function symbols touch the open parenthesis.  In some
+; cases, this results in a touch more space than we like, and perhaps there
+; exists a more delicate kerning command.
+
+           (roman-font (car term))
+           (math-thin-space)
+           (pprinci "("))
+          (t (pprinci "(")
+             (setq term (cons 'foo term))))
+    (cond ((null (cdr term))
+           (pprinci ")"))
+          ((null (cddr term))
+	   ;; infix-print-arg takes a list of args and prints the first.
+	   ;; This allows it to handle &optional.
+           (infix-print-args (cdr term))
+           (pprinci ")"))
+
+; The coder of the printer for each function should consider whether to print
+; flat or not, by calling advise-break.  This is a somewhat aesthetic and
+; heuristic decision.
+
+          (advice
+
+; If it is decided not to print flat, one needs somewhere early to set a tab
+; stop to which to return.
+
+           (set-margin)
+	   (infix-print-args (cdr term) t)
+	   (pprinci ")")
+	   (pop-margin))
+          (t (infix-print-args (cdr term))
+	     (pprinci ")")))))
+
+
+;                                    BREAKS
+
+(defun advise-break (term)
+
+; advise-break is the only place that *testing* is bound, and here it is bound
+; to t, meaning that we want no printing, just want to know if we can print
+; term flat.  We also bind, just to restore, the current *infix-loc* and
+; *tab-list*.
+
+; This first cond is only for debugging purposes.  Same for the second value
+; of the prog1.
+
+  (cond (*tracing-advise-break*
+         (format *terminal-io* "~%Entering *infix-loc* = ~a, *testing* = ~a~%" *infix-loc* *testing*)))
+  (prog1
+      (let ((*infix-loc* *infix-loc*)
+            (*tab-list* *tab-list*))
+        (cond (*testing* nil)
+	      (t (catch 'advise-break
+                   (let ((*testing* t))
+                     (infix-print-term1 term)
+                     nil)))))
+    (cond (*tracing-advise-break*
+           (format *terminal-io* "~%Exiting *infix-loc* = ~a~%" *infix-loc*)))))
+
+;; Next 3 from Nqthm.
+(defparameter *extra-propertyless-symbols-alist* nil)
+
+(defun propertyless-symbolp (x)
+  (or (car-cdrp x)
+      (member x (quote (nil quote list let case cond t f
+                               list*)))
+      (assoc x *extra-propertyless-symbols-alist*)))
+
+(defun car-cdrp (x)
+  (let ((str (symbol-name x)))
+    (cond ((and (> (length str) 2)
+                (eql (aref str 0) #\c)
+                (eql (aref str (1- (length str))) #\r)
+                (sloop for i from 1 to  (- (length str) 2)
+                         always (or (eql (aref str i) #\a)
+                                    (eql (aref str i) #\d))))
+           (sloop for i downfrom (- (length str) 2) to 1 collect
+                    (aref str i)))
+          (t nil))))
+
+(defun advise-break-if-testing ()
+
+; A printer function that is sure that it will break should short circuit the
+; expense of calculating whether printing flat is ok.
+
+  (cond (*testing*
+         (throw 'advise-break t))))
+
+(defun do-not-index-call-of (fn)
+  (or *do-not-index*
+      *do-not-index-calls*
+      (propertyless-symbolp fn)
+      ;; (eq 'ground-zero (get fn 'main-event))
+      (get fn '*predefined*)		;seems appropriate for Acl2.
+      (member fn *do-not-index-calls-of*)))
+      
+(defun index-call (fn)
+  (cond (*testing* nil)
+        ((do-not-index-call-of fn) nil)
+        (t (index fn))))
+
+(defun index-event (fn)
+  (cond (*testing* nil)
+	(*do-not-index* nil)
+        ((do-not-index-event-of fn) nil)
+        (t (index fn))))
+
+(defun infix-print-term1 (term)
+  (cond ((atom term)
+         (funcall (get-atom-printer term) term))
+	((consp (car term))
+	 (sloop for x in term do (infix-print-term1 x)))
+	((not (symbolp (car term)))
+	 (sloop for x in term do (infix-print-term1 x)))
+        (t (funcall (get-fn-printer (car term))
+                    term)
+           (index-call (car term)))))
+
+(defun infix-print-term (term)
+  (newline)
+  (infix-print-term1 term)
+  (newline)
+  nil)
+
+(defun infix-print-list-element-newline (term &optional trailer)
+  ;; TRAILER, if present, must be a string.
+  (infix-print-term1 term)
+  (if trailer (pprinc trailer))
+  (newline)
+  nil)
+
+(defun infix-print-list-element (term &optional trailer)
+  ;; TRAILER, if present, must be a string.
+  (infix-print-term1 term)
+  (if trailer (pprinc trailer))
+  nil)
+
+(defun infix-print-list1 (l)
+  (set-margin)
+  (sloop for tail on l
+	 do (cond ((consp tail)
+		   (infix-print-term1 (car tail))
+		   (if (cdr tail) (pprinci ", ")))
+		  (t (pprinci " . " (infix-print-term1 tail)))))
+  ;; Now we get rid of the indent.
+  (pop-margin))
+
+(defun infix-print-list-a (l &optional printer)
+  (set-margin)
+  (sloop for tail on l
+	 do (cond ((consp tail)
+		   (if printer
+		       (funcall printer (car tail))
+		       (infix-print-term1 (car tail)))
+		   (if (cdr tail) (pprinci ", ")))
+		  (t (pprinci " . ")
+		     (if printer
+			 (funcall printer tail)
+			 (infix-print-term1 tail)))))
+  ;; Now we get rid of the indent.
+  (pop-margin))
+
+(defun infix-print-list (l)
+  (set-margin)
+  (newline)
+  (sloop for tail on l
+	 do (cond ((consp tail)
+		   ;; Issues newline at end of call.
+		   (infix-print-list-element-newline (car tail) (if (cdr tail) ", "))
+		   (cond ((and (cdr tail) (not (consp tail)))
+			  (pprinci " . ") 
+			  (infix-print-list-element-newline (cdr tail))
+			  (loop-return nil))))
+		  ;; Should never get to this.  Sloop doesn't deal with
+		  ;; non-consp cdrs.
+		  (t (pprinci " . ") (infix-print-list-element-newline tail))))
+  ;; Now we get rid of the indent.
+  (pop-margin))
+
+(defun infix-print-l (l &optional printer)
+  (let ((advice (advise-break l)))
+    (if (null printer)
+	(if advice 
+	    (setq printer (function infix-print-list-element-newline))
+	    (setq printer (function infix-print-list-element))))
+    (set-margin)
+    (newline)
+    ;; NEED L TO BE A PROPER LIST.
+    (sloop for tail on l
+	   do (cond ((consp tail)
+		     ;; Issues newline at end of call.
+		     (funcall printer (car tail)
+			      (if (and (cdr tail) (consp (cdr tail)))
+				  ", "
+				  nil))
+		     (if (and (cdr tail) (not (consp (cdr tail))))
+			 (progn (pprinci " . ")
+				(funcall printer (cdr tail))
+				(loop-return nil))))
+		    (t nil)))
+    ;; Now we get rid of the indent.
+    (pop-margin)))
+
+;;   &optional var || &optional (var [literal [varp]]) 
+;;   &rest v
+;;   &key foo bar
+;;   &whole l
+;;   &body l
+;;   &allow-other-keys
+
+(defvar infix-lambda-list-keywords '(&optional &rest &key &whole &body &allow-other-keys))
+
+(defun infix-print-args (l &optional terpri-flag)
+  ;; Whether the args will fit was decided by the caller.
+  ;; If not, terpri-flag is T and we emit a newline between args.
+  ;; Margin is set at current position.
+  (sloop for tail on l
+	 do (let ((arg (car tail)))
+	      (cond ((not (member arg infix-lambda-list-keywords))
+		     (cond ((symbolp arg) (italic-sym-printer arg))
+			   ((and (consp arg) (equal (length arg) 2))
+			    (italic-sym-printer (car arg))
+			    (math-space 1)
+			    (pprinc ":=")
+			    (math-space 1)
+			    (infix-print-term1 (cadr arg)))
+			   ((and (consp arg) (equal (length arg) 3))
+			    (italic-sym-printer (car arg))
+			    (math-space 1)
+			    (pprinc ":=")
+			    (math-space 1)
+			    (infix-print-term1 (cadr arg))
+			    (math-space 1)
+			    (pprinc " flag ")
+			    (math-space 1)
+			    (infix-print-term1 (caddr arg)))
+			 (t (format t "Unrecognized argument type ~s" arg)))
+		     (if (cdr tail) (pprinci ", ")))
+		  (t (small-caps-sym-printer arg) (pprinci " ")))
+	      (if terpri-flag (newline)))) ;newline
+  )
+
+;; Let set-margin and set-tab know if they are in a context where
+;; we are using a left margin followed by a tab.
+(defparameter *left-margin-tab-context* nil)
+
+(defun default-infix-printer (term op)
+  (let* ((top-parens-were-eliminable *top-parens-eliminable*)
+         (*top-parens-eliminable* *top-parens-eliminable-default*)
+         (advice (advise-break term)))
+    (cond ((null top-parens-were-eliminable)
+           (pprinci "(")))
+
+; We hate to see (member x (foo ...)) broken right after the x, where
+; x is an atom.
+
+    (cond ((and advice
+                (not (and (<= (length term) 3)
+                          (atom (cadr term)))))
+	   ;; Note that this INFIX printer expects at least two arguments.
+	   (cond ((consp op)
+		  (if (eq *infix-op-location* 'FRONT)
+		      (smith-infix-print-tail "" term top-parens-were-eliminable)
+		      (boyer-infix-print-tail "" term top-parens-were-eliminable)))
+		 ((eq *infix-op-location* 'FRONT)
+		  (smith-infix-print-tail op (cdr term) top-parens-were-eliminable))
+		 (t (boyer-infix-print-tail op (cdr term) top-parens-were-eliminable))))
+
+	  ((consp op)
+	   (if (eq *infix-op-location* 'FRONT)
+	       (smith-infix-print-tail "" term top-parens-were-eliminable)
+	       (boyer-infix-print-tail "" term top-parens-were-eliminable)))
+          ((= (length term) 2)
+	   ;; We have accidentally captured a unary op.  Since 
+	   ;; We assume these will behave like +/-, e.g. if 
+	   ;; (op x y) prints as "x O y" then (op x) prints as "O x".
+	   (pprinci op 3)
+	   (pprinci " ")
+	   (infix-print-term1 (cadr term))
+	   (if (null top-parens-were-eliminable) (pprinci ")")))
+	  (t
+           (sloop for tail on (cdr term)
+                    do
+                    (progn (infix-print-term1 (car tail))
+                           (cond ((cdr tail)
+                                  (pprinci " ")
+                                  (pprinci op 3)
+                                  (pprinci " "))
+                                 (t (cond ((null top-parens-were-eliminable)
+                                           (pprinci ")")))))))))))
+
+; See `SETTINGS THAT MAY BE MODIFIED IN MODE-THEORY.LISP' for a description
+; of the difference between these two modes of printing.
+
+(defun boyer-infix-print-tail (op args top-parens-were-eliminable)
+  (set-tab)
+  (sloop for tail on args
+           do
+           (progn (infix-print-term1 (car tail))
+                  (cond ((cdr tail)
+                         (newline) (do-tab) ;force-newline
+                         (math-space 5)
+                         (pprinci op 3)
+                         (newline) (do-tab)) ;force-newline
+                        (t (cond ((null top-parens-were-eliminable)
+                                  (pprinci ")")))
+                           (pop-tab))))))
+
+(defun smith-infix-print-tail (op args top-parens-were-eliminable)
+  ;; Does this assume we are in a tabbing env?
+  (set-margin)
+  (set-tab op)
+  ;; (let ((*left-margin-tab-context* t)) ... )
+  (infix-print-term1 (car args))
+  (sloop for tail on (cdr args)
+           do
+           (progn (to-current-margin)
+                  (pprinci op 3)
+                  (do-tab)
+                  (infix-print-term1 (car tail))
+                  (cond ((cdr tail)
+                         (to-current-margin))
+                        (t (cond ((null top-parens-were-eliminable)
+                                  (pprinci ")")))
+                           (pop-margin)
+			   ;; MOD  Nov 30 94 MKS 
+                           ;; (to-current-margin)  ;newline
+			   ))))) 
+
+
+(defun default-unary-prefix-printer (term op)
+  (let* ((top-parens-were-eliminable *top-parens-eliminable*)
+         (*top-parens-eliminable* *top-parens-eliminable-default*))
+    (cond ((null top-parens-were-eliminable)
+           (pprinci "(")))
+    (pprinci op 3)
+    (pprinci " ")
+    (infix-print-term1 (cadr term))
+    (cond ((null top-parens-were-eliminable)
+           (pprinci ")")))))
+
+(defun default-infix-multiple-printer (term strs)
+  (let* ((top-parens-were-eliminable *top-parens-eliminable*)
+         (*top-parens-eliminable* *top-parens-eliminable-default*)
+         (advice (advise-break term)))
+    (cond ((null top-parens-were-eliminable)
+           (pprinci "(")))
+    (if (eq *infix-op-location* 'FRONT)
+        (smith-infix-multiple-printer term strs advice)
+        (boyer-infix-multiple-printer term strs advice))
+    (cond ((null top-parens-were-eliminable)
+           (pprinci ")")))))
+
+(defun boyer-infix-multiple-printer (term strs advice)
+    (set-tab)
+    (infix-print-term1 (cadr term))
+    (sloop for arg in (cddr term)
+             as str in strs do
+             (cond (advice (newline) (do-tab)) ;force-newline
+                   (t (pprinci " ")))
+             (pprinci str)
+             (cond (advice (newline) (do-tab)) ;force-newline
+                   (t (pprinci " ")))
+             (infix-print-term1 arg))
+    (pop-tab))
+
+(defun smith-infix-multiple-printer (term strs advice)
+  (set-margin)
+  ;; (let ((*left-margin-tab-context* nil)) .. )
+  (infix-print-term1 (cadr term))
+  (sloop for arg in (cddr term)
+           as str in strs 
+           do (progn (cond (advice (to-current-margin))	;newline
+                           (t (pprinci " ")))
+                     (pprinci str)
+                     ;;(cond (advice (newline-to-current-margin))
+                     ;;      (t (pprinci " ")))
+                     (pprinci " ")
+                     (infix-print-term1 arg)))
+  (pop-margin))
+
+(defun default-prefix-multiple-printer (term strs)
+  (let* ((top-parens-were-eliminable *top-parens-eliminable*)
+         (*top-parens-eliminable* *top-parens-eliminable-default*)
+         (advice (advise-break term)))
+    (cond ((null top-parens-were-eliminable)
+           (pprinci "(")))
+    (set-margin)
+    ;; (let ((*left-margin-tab-context* nil)) .. )
+    (sloop for tail on (cdr term)
+             as str in strs
+             do (progn (pprinci str)
+                       ;;(cond (advice (newline-to-current-margin))
+                       ;;      (t (pprinci " ")))
+                       (pprinci " ")
+                       (infix-print-term1 (car tail))
+                       (cond ((null tail) nil) 
+                             (advice (to-current-margin)) ;newline
+                             (t (pprinci " ")))))
+    (pop-margin)
+    (cond ((null top-parens-were-eliminable)
+           (pprinci ")")))))
+
+(defun default-suffix-multiple-printer (term strs)
+  (let* ((top-parens-were-eliminable *top-parens-eliminable*)
+         (*top-parens-eliminable* *top-parens-eliminable-default*)
+         (advice (advise-break term)))
+    (cond ((null top-parens-were-eliminable)
+           (pprinci "(")))
+    (set-margin)
+    (sloop for tail on (cdr term)
+             as str in strs
+             do (progn (infix-print-term1 (car tail))
+                       ;;(cond (advice (newline-to-current-margin))
+                       ;;      (t (pprinci " ")))
+                       (pprinci str)
+                       (cond ((null (cdr tail)))
+                             (advice (to-current-margin)) ;newline
+                             (t nil))))
+    (pop-margin)
+    (cond ((null top-parens-were-eliminable)
+           (pprinci ")")))))
+
+(defun default-unary-suffix-printer (term op)
+  (let* ((top-parens-were-eliminable *top-parens-eliminable*)
+         (*top-parens-eliminable* *top-parens-eliminable-default*))
+    (cond ((null top-parens-were-eliminable)
+           (pprinci "(")))
+    (set-margin)
+    (infix-print-term1 (cadr term))
+    (pprinci " ")
+    (pprinci op 3)
+    (pop-margin)
+    (cond ((null top-parens-were-eliminable)
+           (pprinci ")")))))
+        
+(defun default-unary-abs-printer (term lhs-str rhs-str)
+  (let* ((top-parens-were-eliminable *top-parens-eliminable*)
+         (*top-parens-eliminable* *top-parens-eliminable-default*))
+    (cond ((null top-parens-were-eliminable)
+           (pprinci "(")))
+    (set-margin)
+    (pprinci lhs-str)
+    (infix-print-term1 (cadr term))
+    (pprinci rhs-str)
+    (pop-margin)
+    (cond ((null top-parens-were-eliminable)
+           (pprinci ")")))))
+
+
+;                            PRINTING INDEX ENTRIES
+
+; Who could ever have guessed that it would take this much code to print out a
+; simple \index{foo} command for an arbitrary Acl2 function symbol foo.  There
+; are so many special cases one can hardly believe one's eyes.
+
+; Should be re-defined in mode-init.lisp, e.g. latex-init.lisp.
+
+(defparameter index-subitem-length 30)
+
+(defun index (x &optional subkind)
+  ;; Subkind must be string or atom.
+  (pprinc *begin-index*)
+  (cond ((stringp x) (print-string x 0))
+	(t (print-atom x 0)))
+  ;; WARNING: Latex/Scribe dependency.
+  (if subkind
+      (cond ((stringp subkind) (pprinc ", ") (print-string subkind 0))
+            ((symbolp subkind) (pprinc ", ") (print-atom subkind 0))
+            (t nil)))
+  (pprinc *end-index*))
+
+
+;                                EVENT PRINTERS
+
+(defvar *local-context* nil
+  "Indicates when we are in a `local' context, e.g. in encapsulate.")
+
+(defvar *local-handlers* nil 
+  "List of events that are sensitive to *local-context*")
+;; Every -printer that calls event-label printer is so sensitive.
+
+(defmacro local-print (x)
+  `(or (member ',x  *local-handlers*)
+       (setq *local-handlers* (cons ',x *local-handlers*))))
+
+(defun event-doc-string (doc)
+  (cond ((or (null doc) (not (stringp doc)) (string= doc "")))
+	(t (begin-text)
+	   (if *acl2-format-doc-strings*
+	       (let ((pair (acl2-parse-string doc)))
+		 (if (car pair)		;failed
+		     nil
+		     (setq doc (cdr pair)))))
+	   ;; IS PPRINC THE RIGHT THING?  WHAT ABOUT SPECIAL CHARS?
+	   ;; I think so.
+	   (pprinci doc)
+	   (to-current-margin)
+	   (end-text)
+	   (blankline))))
+
+(defun print-default-event-header ()
+  (ppformat *print-default-event-header*)
+  (setq *infix-loc* 0))
+
+(defun no-tab-event-trailer ()
+  (ppformat *no-tab-event-trailer*))
+
+(defun print-default-command-header ()
+  (ppformat *print-default-command-header*)
+  (setq *infix-loc* 0))
+
+(defun no-tab-command-trailer ()
+  "May occur in a tabbing env. due to an encapsulate.
+In which case we don't want to print *no-tab-command-trailer*."
+  (if *tab-stack* (blankline) (ppformat *no-tab-command-trailer*)))
+
+(defun event-label-printer (label &optional lowercase)
+  (if *local-context* (small-caps-sym-printer "LOCAL "))
+  (small-caps-sym-printer label)
+  (if lowercase (pprinc lowercase)))
+
+(eval-when (load compile eval)
+
+(defun begin-event (&optional doc) 
+  (blankline)
+  (event-doc-string doc)
+  (begin-tabbing)
+  (line-return))
+
+(defmacro end-event ()
+  '(progn (end-tabbing)
+	  (blankline)))
+
+(defmacro begin-paragraph () 
+  `(progn (blankline) (begin-text)))
+
+(defmacro end-paragraph () 
+  `(progn (end-text) (blankline)))
+
+)
+
+;; acl2    == segment*
+;; segment == text blankline || event blankline
+;; event   == [ doc blankline ] begin-event body [ keys ] end-event
+;; body    == type header = form || type header acl2
+
+(defun default-event-printer (event)
+  (begin-event)
+  (if *local-context*
+      (event-label-printer "Local Event" " (of unknown type):  ")
+      (event-label-printer "Event" " (of unknown type):  "))
+  (newline)
+  (quote-printer1 event)
+  (end-event))
+
+(defun extract-keywords (l keys)
+  (cond ((not (consp keys)) nil)
+	((member (car keys) l)
+	 (cons (cadr (member (car keys) l)) 
+	       (extract-keywords l (cdr keys))))
+	(t (cons nil (extract-keywords l (cdr keys))))))
+
+
+(defun defcor-printer (event)
+  (let* ((name (nth 1 event))
+	 (old-event (nth 2 event))
+	 (keys (extract-keywords event '(:rule-classes :doc)))
+	 (rule-classes (car keys))
+	 (doc (cadr keys)))
+    (begin-event doc)
+    (event-label-printer "Corollary: ")
+    (print-atom name)
+    (pprinci " is a corollary to ")
+    (print-atom old-event)
+    (pprinci ".")
+    (index name)
+    (to-current-margin)
+    (cond ((and (consp rule-classes)
+		(consp (car rule-classes))
+		(equal (car (car rule-classes)) :rewrite)
+		(consp (cdr (car rule-classes)))
+		(equal (car (cdr (car rule-classes))) :corollary))
+	   (infix-print-term (cadr (cdr (car rule-classes)))))
+	  (t (pprinc "Rule Classes: ")
+	     (infix-print-term rule-classes)))
+    (end-event)))
+
+(local-print defcor)
+
+
+(defun defequiv-printer (event)
+  (let* ((fn (nth 1 event))
+	 (keys (extract-keywords event '(:rule-classes :doc)))
+	 (rule-classes (car keys))
+	 (doc (cadr keys)))
+    (begin-event doc)
+    (event-label-printer "Equivalence relation: ")
+    (print-atom fn)
+    (index fn)
+    (flushright-rule-classes rule-classes)
+    (end-tabbing)))
+
+(local-print defequiv)
+
+(defun defdoc-printer (term)
+  (ppformat "~%New documentation for: ~s.~%" (cadr term))
+  (pprinci (caddr term)))
+
+(defun flushright-rule-classes (rules)
+  (if rules
+      (progn (begin-flushright)
+	     (rule-class-printer rules)
+	     (end-flushright))))
+
+
+(defun defaxiom-printer (term)
+  ;; name term :rule-clases clases :doc string
+  (let* ((name (nth 1 term))
+         (subterm (nth 2 term))
+         (keys (extract-keywords term '(:rule-classes :doc)))
+         (rule-classes (car keys))
+         (doc (cadr keys)))
+    (begin-event doc)
+    (event-label-printer "Axiom: ")
+    (print-atom name)
+    (index name)
+    (flushright-rule-classes rule-classes)
+    (infix-print-term subterm)
+    (end-event)))
+
+(local-print defaxiom)
+
+
+(defun defcong-printer (term)
+  ;; equiv1 k equiv2 fn :rule-classes :instructions :hints :otf-flg :cheat :doc
+  (let* ((equiv1 (nth 1 term))
+         (equiv2 (nth 2 term))
+         (fn (nth 3 term))
+         (arity (nth 4 term))
+         (keys (extract-keywords term '(:rule-classes :instructions :hints :otf-flg :doc)))
+         (rule-classes (nth 0 keys))
+         (doc (nth 4 keys)))
+    (begin-event doc)
+    (event-label-printer "Equivalence relation: ")
+    (print-atom equiv1)
+    (small-caps-sym-printer " preserves ")
+    (print-atom equiv2)
+    (to-current-margin)
+    (small-caps-sym-printer " for argument position ")
+    (print-atom arity)
+    (small-caps-sym-printer " of ")
+    (infix-print-term1 fn)
+    (index equiv1 "equivalence")
+    (index equiv2 "equivalence")
+    (if (consp fn) (index (car fn)))
+    (flushright-rule-classes rule-classes)
+    (newline)
+    (end-event)))
+
+(local-print defcong)
+
+
+(defun defconst-printer (event)
+  (let ((name (nth 1 event))
+        (term (nth 2 event))
+        (doc  (nth 3 event)))
+    (begin-event doc)
+    (event-label-printer "Constant: ")
+    (infix-print-term (list 'equal name term))
+    (end-event)))
+
+(local-print defconst)
+
+(defun defevaluator-printer (term)
+  ;; ev ev-list signatures
+  (let ((ev (nth 1 term))
+	(ev-list (nth 2 term))
+	(signatures (cadddr term)))
+    (begin-event "Define an evaluator.")
+    (ppformat "Let `~s' be an evaluator function, with mutually-recursive counterpart
+`~s', for the functions" ev ev-list) 
+    (print-bare-function-names (mapcar (function car) signatures))
+    (index ev)
+    (index ev-list)
+    (end-event)))
+
+(local-print defevaluator)
+
+
+(defun deflabel-printer (event)
+  (let* ((name (nth 1 event))
+         (keys (extract-keywords event '(:doc)))
+         (doc (nth 0 keys)))
+    (begin-event doc)
+    (event-label-printer "Label: ")
+    (print-atom name)
+    (index name)
+    (end-event)))
+
+(local-print deflabel)
+
+
+(defun defrefinement-printer (term)
+  ;; equiv1 equiv2 :rule-classes :instructions :hints :otf-flg :doc
+  (let* ((eq1 (nth 1 term))
+         (eq2 (nth 2 term))
+         (keys (extract-keywords term '(:rule-classes :instructions :hints :otf-flg :doc)))
+         ;(rule-classes (nth 0 keys))
+         (doc (nth 4 keys)))
+    (begin-event doc)
+    (event-label-printer "Refinement: ")
+    (print-atom eq1)
+    (small-caps-sym-printer " refines ")
+    (print-atom eq2)
+    (index eq1)
+    (index eq2)
+    (end-event)))
+
+(local-print defrefinement)
+
+
+(defun defpkg-printer (event)
+  (let ((name (nth 1 event))
+        ; (contents (nth 2 event))
+        (doc  (if (> (length event) 3) (nth 3 event))))
+    ;;
+    ;; We do the following so that we can print and
+    ;; read symbols in this package.
+    ;;
+    (if (not (find-package name)) (make-package name))
+    ;;
+    (begin-event doc)
+    (event-label-printer "Package ")
+    (bold-sym-printer name)
+    (index name " defined")
+    ;; (infix-print-term contents)    
+    (to-current-margin)
+    (end-event)))
+
+
+(defun in-package-printer (event)
+  (let ((name (nth 1 event)))
+    ;;
+    ;; We do the following so that we can print and
+    ;; read symbols in this package.
+    ;;
+    (if (not (find-package name)) (make-package name))
+    ;;
+    (begin-event)
+    (event-label-printer "Set current package" " to be ")
+    (bold-sym-printer name)
+    (pprinc ".") (index name "package used")
+    (end-event)))
+
+(local-print in-package)
+
+(defun rebuild-printer (event)
+  (let ((name (nth 1 event))
+	(key  (if (cddr event) (caddr event))))
+    (begin-event)
+    (event-label-printer "Rebuild ")
+    (italic-sym-printer name)
+    (cond ((or (null key)
+	       (equal key t)	       
+	       (equal key :all)
+	       (equal key :query))
+	   (pprinc "."))
+	  ((symbolp key) (ppformat " through  ~s." (symbol-name key)))
+	  ((and (consp key)
+		(eq (car key) 'quote)
+		(symbolp (cadr key)))
+	   (ppformat " through  ~s." (symbol-name (cadr key))))
+	  (t (ppformat ".")))
+    (end-event)))
+
+(local-print rebuild)
+
+(defun filename-sym-printer (x)
+  (italic-sym-printer (acl2-smash-file-name x)))
+
+;; A file (to acl2) may be a string or
+;; (:ABSOLUTE . string* )
+;; (:RELATIVE . string* )
+
+(defun acl2-file-name-root (file)
+  (cond ((not (consp file)) file)
+	(t (car (last file)))))
+
+(defun acl2-smash-file-name (file)
+  (cond ((not (consp file))
+	 (cond ((stringp file) file)
+	       ((symbolp file) (symbol-name file))
+	       (t "")))
+	((equal (car file) :absolute)
+	 (concatenate 'string "/" (acl2-smash-file-name (cdr file))))
+	((equal (car file) :relative)
+	 (acl2-smash-file-name (cdr file)))
+	((equal (car file) :back)
+	 (concatenate 'string "../" (acl2-smash-file-name (cdr file))))
+	((cdr file) (concatenate 'string (car file) "/" (acl2-smash-file-name (cdr file))))
+	(t (car file))))
+
+
+(defun include-book-printer (event)
+  (let* ((file (nth 1 event))
+	 (root (acl2-file-name-root file))
+	 (keys (extract-keywords event '(:doc)))
+	 (doc (nth 0 keys)))
+    (begin-event doc)
+    (event-label-printer "Including" " the book: ")
+    (filename-sym-printer file)
+    (pprinc ".") (index root "included")
+    (end-event)))
+
+(local-print include-book)		;???
+
+
+(defun certify-book-printer (event)
+  (let* ((file (nth 1 event))
+	 (root (acl2-file-name-root file)))
+    (begin-event)
+    (event-label-printer "Certifying" " the book: ")
+    (filename-sym-printer file)
+    (pprinc ".") (index root "certified")
+    (end-event)))
+
+(local-print certify-book)		;???
+
+(defun infix-print-macro-body (body)
+  (cond ((not (consp body)) (infix-print-term1 body))
+	((equal (car body) 'quote)
+	 (pprinc "'") (infix-print-term1 (cadr body)))
+	((equal (car body) '*infix-backquote*)
+	 (pprinc "`") (infix-print-term1 (cadr body)))
+	(t (infix-print-term1 body))))
+  
+
+(defun defmacro-printer (event)
+  (let* ((name (nth 1 event))
+	 ;; Note that macro args may include &optional or &rest.
+         (args (nth 2 event))
+         (doc  (nth 3 event))
+         (body (car (last event)))
+         (form (cons name args)))
+    (begin-event doc)
+    (event-label-printer "Macro: ")
+    (index name "defined")
+    (to-current-margin)
+    ;; Can we fit the defun on one line?
+    (cond ((let ((*rightmost-char-number* (- *rightmost-char-number* 12)))
+             (advise-break (list 'equal form body)))
+           ;; No.
+           (defun-call-part-printer form)
+           (to-current-margin)		;newline
+           (pprinci (format nil " ~a " (get 'equal 'literalform)))
+	   (to-current-margin)		;(new-tab-row t)
+           (infix-print-macro-body body))
+          (t (defun-call-part-printer form)
+             (pprinci (format nil " ~a " (get 'equal 'literalform)))
+	     (infix-print-macro-body body)))
+    (to-current-margin)
+    (end-event)))
+
+(local-print defmacro)
+
+
+(defun defstub-printer (event)
+  (let ((name (nth 1 event))
+        (args (nth 2 event))
+        (result (nth 3 event)))
+    (begin-event)
+    (event-label-printer "Function: ")
+    (infix-print-term1 (cons name args))
+    ;; (if (equal 1 (length args))
+    ;;     (pprinc " of one argument.")
+    ;;     (ppformat " of ~a arguments." (length args))))
+    (cond ((symbolp result))
+          (t (ppformat ". Returns ~a results." (length (cdr result)))))
+    (end-event)))
+
+(local-print defstub)
+
+(defun rule-class-printer (classes)
+  ;; classes is either keyword or a list of keywords or
+  ;; lists whose car is a keyword.
+  (cond ((consp classes)
+	 (rule-class-print (car classes))
+	 (mapc (function (lambda (x) (print-string ", ") (rule-class-print x))) (cdr classes)))
+	(t (rule-class-print classes))))
+
+(defun rule-class-print (class)
+  (cond ((keywordp class) (italic-sym-printer class))
+	((keywordp (car class)) (italic-sym-printer (car class)))
+	(t nil)))
+
+
+(defun defthm-printer (term)
+  ;; name term :rule-classes :instructions :hints :otf-flg :doc
+  (let* ((name (nth 1 term))
+         (subterm (nth 2 term))
+         (keys (extract-keywords term '(:rule-classes :instructions :hints :otf-flg :doc)))
+         (rule-classes (nth 0 keys))
+         (doc (nth 4 keys)))
+    (begin-event doc)
+    (event-label-printer "Theorem: ")
+    (print-atom name)
+    (index name)
+    (flushright-rule-classes rule-classes)
+    (infix-print-term subterm)
+    (end-event)))
+
+(local-print defthm)
+
+(defparameter *noindent* nil)
+(defvar *indent-string* " ")
+(defvar *default-indent* 2)
+
+(defun begin-indent (&optional newline (indent *default-indent*))
+  (if newline (newline))
+  (sloop for i from 1 to indent do (pprinc *indent-string*))
+  (set-margin))
+
+(defun end-indent ()
+  (pop-margin)
+  (line-return))
+
+
+
+
+(defun encapsulate-printer (term)
+  (let ((signatures (nth 1 term))
+        (events (cddr term)))
+    (begin-event)
+    (event-label-printer "Begin Encapsulation")
+    (if signatures
+	(progn (blankline)
+	       (event-label-printer "Constrain" " the functions: ")
+	       ;; SCRIBE SPECIFIC BRANCH.
+	       (if (or (string= *infix-mode* "scribe")
+		       (string= *infix-mode* "SCRIBE"))
+		   (blankline))
+	       (begin-indent)
+	       (mapc (function (lambda (x)
+				 (defstub-printer (cons 'defstub x))))
+		     signatures)
+	       (end-indent)
+	       ;(blankline)
+	       (small-caps-sym-printer "according to the following events:  ")))
+    (blankline)
+    (begin-indent)
+    (mapc (function (lambda (x) (infix-event x))) events)
+    (end-indent)
+    (blankline)
+    (small-caps-sym-printer "End encapsulatation.")
+    (end-event)))
+
+(defun skip-proofs-printer (term)
+  (let ((event (nth 1 term)))
+    (ppformat "~%The proofs normally generated by the following event are being skipped.~%~%")
+    (funcall (get-event-printer (car event)) event)))
+
+
+
+
+(defun local-printer (term)
+  (let ((event (cadr term))
+	(*local-context* t))
+    (if (and (consp event) (member (car event) *local-handlers*))
+	(infix-event event)
+        (progn (event-label-printer "Local event: ")
+	       (infix-event event)))))
+
+
+(defun mutual-recursion-printer (term)
+  (let ((events (cdr term)))
+    (mapc (function (lambda (x) (infix-event x))) events)))
+
+
+(defun defuns-printer (term)
+  (let ((events (cdr term)))
+    (mapc (function (lambda (x) (infix-event (cons 'defun x)))) events)))
+
+
+(defun ld-printer (term)
+  (let ((keys (extract-keywords term '(:standard-co :proofs-co :current-package
+				       :ld-skip-proofsp :ld-redefinition-action
+				       :ld-prompt :ld-keyword-aliases :ld-pre-eval-filter
+				       :ld-pre-eval-print :ld-post-eval-print :ld-evisc-tuple
+				       :ld-error-triples :ld-error-action
+				       :ld-query-control-alist :ld-verbose)))) 
+    (begin-event)
+    (event-label-printer "Load" " the file: ")
+    (filename-sym-printer (cadr term))
+    (end-event)
+    (if keys
+	(let ((pairs (pairlis '(:standard-co :proofs-co :current-package
+			        :ld-skip-proofsp :ld-redefinition-action
+				:ld-prompt :ld-keyword-aliases :ld-pre-eval-filter
+				:ld-pre-eval-print :ld-post-eval-print :ld-evisc-tuple
+				:ld-error-triples :ld-error-action
+				:ld-query-control-alist :ld-verbose)
+			      keys)))
+	  (pprinc "Loaded with the following settings: ")
+	  (print-settings-list pairs)))
+    (blankline)))
+
+(defun infix-print-setting (a)
+  ;; X is pair of form keyword . setting.
+  (let ((f (get-keyword-printer (car a))))
+    (funcall f a)))
+
+(defun print-settings-list (pairs)
+  (sloop for tail on pairs
+	 do (cond ((not (consp tail)))
+		  ((cddr tail)
+		   (infix-print-setting (car tail))
+		   (pprinci ", "))
+		  ((cdr tail)
+		   (infix-print-setting (car tail)))
+		  (t
+		   (pprinci " and ")
+		   (infix-print-setting (car tail)) (pprinci ".")))))
+
+(defun extract-declare-xarg (dcls)
+  ;; dcls = ((DECLARE arg*))
+  ;; arg  = xarg || other
+  ;; xarg = (XARGS key value ...)
+  ;; key  = :guard || :measure || :mode
+  (cond ((null dcls) nil)
+	((consp (car dcls))
+	 (let ((dcl (car dcls)))
+	   (cond ((and (equal (car dcl) 'declare)
+		       (equal (car (cadr dcl)) 'xargs))
+		  (append (cdr (cadr dcl))
+			  (extract-declare-xarg (cdr dcls))))
+		 (t (extract-declare-xarg (cdr dcls))))))
+	(t (extract-declare-xarg (cdr dcls)))))
+
+(defun print-decls (dcls)
+  (print-decls2 (extract-declare-xarg dcls)))
+
+(defun print-decls2 (dcls)
+  (if (null dcls)
+      nil
+    (let* ((keys (extract-keywords dcls '(:measure :guard :mode)))
+	   ;; Left out :well-founded-relation, :hints, :guard-hints, verify-guards, :otf-flag
+	   (measure (nth 0 keys))
+	   (guard   (nth 1 keys))
+	   (mode    (nth 2 keys)))
+      (when measure
+	(bold-sym-printer "Measure: ")
+	(set-margin)
+	(infix-print-term1 measure)
+	(pop-margin))		  
+      (when mode
+	(bold-sym-printer "Mode: ")
+	(print-atom mode)
+	(to-current-margin))		;newline
+      (when guard
+	(bold-sym-printer "Guard: ")
+	(set-margin)
+	(infix-print-term1 guard)
+	(pop-margin)
+	(to-current-margin)))))		;newline
+
+
+
+(defun defun-printer1 (term equiv)
+  ;; (defun name args doc-string dcl ... dcl body)
+  (let* ((name (nth 1 term))
+         (args (nth 2 term))
+         (doc (if (stringp (nth 3 term)) (nth 3 term)))
+         (form (cons name args))
+         (body (car (last term)))
+	 (eq (list equiv form body))
+         dcls)
+    (sloop for x in (cdddr term)
+	   do (if (or (stringp x)
+		      (equal x body))
+		  nil
+		  (setq dcls (append dcls (list x)))))
+    (begin-event doc)
+    (event-label-printer "Definition: ")
+    (index name "defined")
+    (to-current-margin)
+    ;; Can we fit the defun on one line?
+    (cond ((let ((*rightmost-char-number* (- *rightmost-char-number* 12)))
+            (advise-break eq))
+           ;; No.
+           (infix-print-term1 form)
+           (to-current-margin)		;newline
+           (pprinci (format nil " ~a " (get equiv 'literalform)) 3)
+           ;; (new-tab-row t)
+           (infix-print-term body))
+          (t (infix-print-term1 form)
+             (pprinci (format nil " ~a " (get equiv 'literalform)) 3)
+             (infix-print-term1 body)))
+    (to-current-margin)
+    (print-decls dcls)
+    (end-event)))
+
+
+(defun defun-printer (term)
+  (defun-printer1 term 'equal))
+
+(local-print defun)
+(local-print define)
+
+(defun forall-printer (term)
+  (let  ((vars (nth 1 term))
+	(body (nth 2 term)))
+    (pprinci *forall* *tt-size*)
+    (cond ((atom vars)
+           (funcall (get-atom-printer vars) vars))
+          (t (sloop for tail on vars do
+                      (funcall (get-atom-printer (car tail)) (car tail))
+                      (cond ((cdr tail)
+                             (pprinci ", " *tt-size*))))))
+    (pprinc ":")
+    (math-space 1)
+    (infix-print-term1 body)))
+
+(defun exists-printer (term)
+  (let ((vars (nth 1 term))
+	(body (nth 2 term)))
+    (pprinci *exists* *tt-size*)
+    (cond ((atom vars)
+	   (funcall (get-atom-printer vars) vars))
+          (t (sloop for tail on vars do
+		    (funcall (get-atom-printer (car tail)) (car tail))
+		    (cond ((cdr tail)
+			   (pprinci ", " *tt-size*))))))
+    (pprinc ":")
+    (math-space 1)
+    (infix-print-term1 body)))
+
+(declare-fn-printer exists (function exists-printer))
+(declare-fn-printer forall (function forall-printer))
+
+
+;; Rune                           Runic Desig
+;;  def = symbolp   :functionp ==  (:DEFINITION symb).
+;;  ex  = (symbolp) :functionp ==  (:EXECUTABLE-COUNTERPART symb)
+;;  thm = symbolp   :defthm    ==  {...} set introduced
+;;  ax  = symbolp   :defaxiom  ==  {...} set introduced
+;;  th  = symbolp   :deftheory ==  {...} set introduced
+
+;; runic-desig    = def | ex | thm | ax | theory | ?? string
+;; runic-des  ==   sym | (sym)
+;; rune       ==   (:DEFINITION sym) | (:EXECUTABLE-COUNTERPART sym)
+;;               | (:REWRITE sym)    | (:REWRITE sym)
+;;               | (:ELIM sym)       | runic-des
+
+
+
+(defun print-rune-string (rune)
+  (cond ((eq rune :here)     (pprinc "the current theory"))
+	((not (consp rune))  (print-bare-function-name rune))
+	((null (cdr rune))
+	 (pprinc "the executable counterpart of ")
+	 (print-bare-function-name (car rune)))
+	((eq (car rune) :executable-counterpart)
+	 (pprinc "the executable counterpart of ")
+	 (print-bare-function-name (cadr rune)))
+	((eq (car rune) :definition)
+	 (pprinc "the definition of ")
+	 (print-bare-function-name (cadr rune)))
+	((eq (car rune) :rewrite)
+	 (pprinc "the rewrite rule, ")
+	 (print-bare-function-name (cadr rune)))
+	((eq (car rune) :elim)
+	 (pprinc "the elimination rule, ")
+	 (print-bare-function-name (cadr rune)))
+	(t (pprinc "the ") (print-atom (car rune))
+	   (pprinc " rule, ")
+	   (print-bare-function-name (cadr rune)))))
+
+(defun runes-print (runes)
+  (cond ((cdr runes)
+	 (sloop for x on runes
+		do (cond ((cddr x)
+			  (print-rune-string (car x))
+			  (pprinc ", "))
+			 ((cdr x)
+			  (print-rune-string (car x))
+			  (pprinc " and "))			 
+			 (t (print-rune-string (car x))))))
+	(t (print-rune-string (car runes)))))
+
+;; name       ==   sym | string | :here   -- event name
+;; theory     ==   (rune*)                -- sets of runes to enable/disable in concert
+;; theory-des == 
+;;      (DISABLE runic-desig*)            => theory        
+;;    | (ENABLE  runic-desig*)            => theory        
+;; 
+;;    | (CURRENT-THEORY   name)           => theory  -- name is atom, string, or :here
+;;    | (UNIVERSAL-THEORY name)           => theory  -- as of logical name
+;;    | (THEORY           name)           => theory        
+;;    | (FUNCTION-THEORY  name)           => theory  -- function symbol rules
+;;
+;;    | (INTERSECTION-THEORIES th1 th2)   => theory
+;;    | (SET-DIFFERENCE-THEORIES th1 th2) => theory
+;;    | (UNION-THEORIES th1 th2)          => theory
+
+
+(defun theory-print (form &optional (tail ""))
+  (cond ((not (consp form))
+	 (pprinci (format nil "the theory "))
+	 (bold-sym-printer form)
+	 (pprinci tail))
+	((eq (car form) 'quote) (runes-print (cadr form)) (pprinci tail))
+	(t (or *do-not-use-tabs* (begin-tabbing))
+	   (infix-print-term1 form)(pprinci tail)
+	   (or *do-not-use-tabs* (end-tabbing)))))
+
+(defun deftheory-printer (event)
+  (let* ((name (nth 1 event))
+         (theory (nth 2 event))
+         (keys (extract-keywords event '(:doc)))
+         (doc (nth 0 keys)))
+    (event-doc-string doc)
+    (newline)
+    (begin-text)
+    (line-return)
+    (event-label-printer "Define" " the theory ")
+    (bold-sym-printer name)
+    (index name "theory")
+    (pprinc " to be ")
+    (theory-print theory ".")
+    (end-text)
+    (blankline)))
+
+(local-print deftheory)
+
+
+(defun in-theory-printer (event)
+  (let* ((theory (nth 1 event))
+         (keys (extract-keywords event '(:doc)))
+         (doc (nth 0 keys))
+	 *do-not-use-tabs*)
+    (event-doc-string doc)
+    (newline)
+    (begin-text)
+    (line-return)
+    (event-label-printer "Modify" " the current theory: ")
+    (theory-print theory ".")
+    (end-text)
+    (blankline)))
+
+(local-print in-theory)
+
+
+(defun boot-strap-printer (term)
+  (declare (ignore term))
+  (begin-event)
+  (event-label-printer "Start" " with the initial Acl2 theory.")
+  (end-event))
+
+
+(defun verify-guards-printer (event)
+  (let* ((name (nth 1 event))
+	 (keys (extract-keywords event '(:doc)))
+	 (doc (nth 0 keys)))
+    (begin-event doc)
+    (event-label-printer "Verify guards" " for ")
+    (print-bare-function-name name)
+    (index name "guard verification")
+    (end-event)))
+
+(local-print verify-guards)
+
+
+;;    (verify-termination fn dcl ... dcl)
+;; or (verify-termination (fn1 dcl ... dcl) (fn2 dcl ... dcl) ...)
+
+(defun verify-termination-printer (event)
+  (begin-event)
+  (event-label-printer "Verify termination" " for ")
+  (set-margin)
+  (let ((events (if (symbolp (cadr event))
+		    (list (cdr event))
+		    (cdr event))))
+    (mapl (function (lambda (x)
+		      (progn (print-verify-termination (car x))
+			     (to-current-margin))))
+	  events))
+  (pop-margin)
+  (end-event))
+
+(local-print verify-termination)
+
+(defun print-verify-termination (x)
+  (cond ((consp x)
+	 (pprinc " ")
+	 (print-bare-function-name (car x))
+	 (pprinc " with ")
+	 (print-decls (cdr x)))
+	(t (pprinc " ") (print-bare-function-name x))))
+
+(defun disable-printer (form)
+  (pprinc "Disable ")
+  (runes-print (cdr form)))
+
+(declare-fn-printer disable (function disable-printer))
+
+(defun enable-printer (form)
+  (pprinc "Enable ")
+  (runes-print (cdr form)))
+
+(declare-fn-printer enable (function enable-printer))
+
+(defun current-theory-printer (form)
+  (cond ((eq (cadr form) :here)
+	 (pprinci "the current theory "))
+	((and (consp (cadr form)) (eq (car (cadr form)) 'quote))
+	 (pprinci (format nil "the theory as of ~a" (cadr (cadr form)))))
+	(t (pprinci (format nil "the theory as of ~a" (cadr form))))))
+
+(declare-fn-printer current-theory (function current-theory-printer))
+
+(defun universal-theory-printer (form)
+  (cond ((eq (cadr form) :here)
+	 (pprinci "the current universal theory "))
+	((and (consp (cadr form)) (eq (car (cadr form)) 'quote))
+	 (pprinci (format nil "the theory as of ~a" (cadr (cadr form)))))
+	(t (pprinci (format nil "the universal theory as of ~a" (cadr form))))))
+
+(declare-fn-printer universal-theory (function universal-theory-printer))
+
+(defun theory-printer (form)
+  (cond ((eq (cadr form) :here)
+	 (pprinci "the current theory "))
+	((and (cadr form) (consp (cadr form)) (eq (car (cadr form)) 'quote))
+	 (pprinci "the theory ") (bold-sym-printer (cadr (cadr form))))
+	(t (pprinci (format nil "the theory ~a" (cadr form))))))
+
+(declare-fn-printer theory (function theory-printer))
+
+(defun function-theory-printer (form)
+  (cond ((eq (cadr form) :here)
+	 (pprinci "the current function theory "))
+	((and (cadr form) (consp (cadr form)) (eq (car (cadr form)) 'quote))
+	 (pprinci "the function theory ") (bold-sym-printer (cadr (cadr form))))
+	(t (pprinci (format nil "the function theory ~a" (cadr form))))))
+
+(declare-fn-printer function-theory (function function-theory-printer))
+
+;; See scribe or latex init to see how the following are handled.
+;;  intersection-theories  
+;;  set-difference-theories
+;;  union-theories         
+
+(defun theory-invariant-printer (form)
+  (let ((term (cadr form))
+	(key  (if (cddr form) (caddr form) nil)))
+    (cond ((eq (car term) 'incompatible)
+	   (print-rune-string (cadr term))
+	   (pprinc " is incompatible with ")
+	   (print-rune-string (caddr term))
+	   (pprinc " in this theory")
+	   (if key (pprinc "Call this invariant ") (print-atom key)))
+	  (t (cond (key (pprinc (format nil "Invariant [~a]: " key))
+			(infix-print-term1 (term)))
+		   (t (pprinc "Invariant : ")
+			(infix-print-term1 (term))))))))
+
+(declare-fn-printer theory-invariant (function theory-invariant-printer))
+
+(defun defun-sk-printer (event)
+  ;; (defun-sk name args body &key doc quant-ok skolem-name thm-name)
+  (let* ((name (nth 1 event))
+         (args (nth 2 event))
+         (body (nth 3 event))
+	 (keys (extract-keywords event '(:doc :quant-ok :skolem-name :thm-name)))
+	 (doc (nth 0 keys))
+         (form (cons name args))
+         (eq (list 'equal form body)))
+    (begin-event doc)
+    (event-label-printer "Definition w/quantifier: ")
+    (index name "defined with quantifier")
+    (to-current-margin)
+    ;; Can we fit the defun on one line?
+    (cond ((let ((*rightmost-char-number* (- *rightmost-char-number* 12)))
+            (advise-break eq))
+           ;; No.
+           (infix-print-term1 form)
+           (to-current-margin)		;newline
+           (pprinci (format nil " ~a " (get 'equal 'literalform)) 3)
+           ;; (new-tab-row t)
+           (infix-print-term body))
+          (t (infix-print-term1 form)
+             (pprinci (format nil " ~a " (get 'equal 'literalform)) 3)
+             (infix-print-term1 body)))
+    (to-current-margin)
+    (end-event)))
+
+;; (  LEFT IN ----------
+
+(defun do-file-printer (term)
+  (print-default-event-header)
+  (pprinc "Do all forms in the file:
+")
+  (italic-sym-printer (cadr term))
+  (no-tab-event-trailer))
+
+(defun setq-printer (term)
+  (print-default-event-header)
+  (let (name value)
+    (match term (setq name value))
+    (ppformat "Give the Acl2 control variable ")
+    (tt-sym-printer name)
+    (ppformat " the value ")
+    (tt-sym-printer value)
+    (ppformat "."))
+  (no-tab-event-trailer))
+
+(defun comp-printer (term)
+  ":comp t          - compile all uncompiled ACL2 functions
+:comp foo        - compile the defined function foo
+:comp (foo bar)  - compile the defined functions foo and bar"
+  (print-default-command-header)
+  (cond ((null (cdr term))
+         (pprinc "Unknown compile command."))
+        ((equal (cadr term) t)
+	 (pprinc "Compile all uncompiled ACL2 functions."))
+        ((symbolp (cadr term))
+	 (pprinc "Compile ")
+           (print-bare-function-name (cadr term))
+           (pprinc "."))
+        (t (pprinc "Compile ")
+           (print-bare-function-names (cadr term))
+           (pprinc ".")))
+  (no-tab-command-trailer))
+
+(defmacro define-command-printer (name string)
+  (let ((fn-name (intern (format nil "~s-COMMAND-PRINTER" name))))
+    `(progn
+       (clean-up ',name)
+       (defun ,fn-name
+         (term)
+	 (declare (ignore term))
+	 (print-default-command-header)
+	 (pprinc ,string)
+	 (no-tab-command-trailer))
+       (declare-command-printer ,name (function ,fn-name)))))
+
+(defun checkpoint-forced-goals-printer (term)
+  (print-default-command-header)
+  (if (cadr term)
+      (pprinc "Checkpoint forced goals.")
+      (pprinc "Do not checkpoint forced goals."))
+  (no-tab-command-trailer))
+
+(define-command-printer disable-forcing "Disable forcing.")
+(define-command-printer enable-forcing "Enable forcing.")
+(define-command-printer good-bye "Exiting both ACL2 & lisp.")
+(define-command-printer oops-printer "Redo last undo.")
+
+(defun puff-printer (term)
+  (print-default-command-header)
+  (pprinc "Expand command ")
+  (print-atom (cadr term))
+  (pprinc ".")
+  (no-tab-command-trailer))
+
+(defun puff*-printer (term)
+  (print-default-command-header)
+  (pprinc "Expand command ")
+  (print-atom (cadr term))
+  (pprinc " recursively.")
+  (no-tab-command-trailer))
+
+(define-command-printer q "Quitting ACL2.")
+(define-command-printer redef "Allow redefinition without undoing.")
+(define-command-printer redef!
+ "!!! ACL2 system hacker's redefinition command:
+Allow redefinition (even of system functions) without undoing.")
+
+(defun reset-ld-specials-printer (term)
+  (print-default-command-header)
+  (pprinc "Reset LD specials to their initial value")
+  (if (cadr term)
+      (pprinc ", including I/O channels.")      
+      (pprinc "."))
+  (no-tab-command-trailer))
+
+(defun set-cbd-printer (term)
+  (print-default-command-header)
+  (pprinc "Set connected book directory to ")
+  (filename-sym-printer (cadr term))
+  (pprinc ".")
+  (no-tab-command-trailer))
+
+(defun set-guard-checking-printer (term)
+  (print-default-command-header)
+  (if (cadr term)
+      (pprinc "Set guard checking on.")
+      (pprinc "Set guard checking off."))
+  (no-tab-command-trailer))
+
+(define-command-printer start-proof-tree "Start prooftree logging.")
+(define-command-printer stop-proof-tree "Stop prooftree logging.")
+(define-command-printer u "Undo last event.")
+
+(defun ubt-printer (term)
+  (print-default-command-header)
+  (cond ((null (cdr term))
+         (pprinc "Undo the last event."))
+        (t (pprinc "Undo back through the event named `")
+           (print-atom (cadr term))
+           (pprinc "'.")))
+  (no-tab-command-trailer))
+
+(defun retrieve-printer (term)
+  (print-default-command-header)
+  (pprinc "Re-enter proof-checker state")
+  (if (cadr term)
+      (ppformat " named ~s." (cadr term))
+      (pprinc "."))
+  (no-tab-command-trailer))
+
+(define-command-printer unsave "")
+(define-command-printer save "")
+
+(defun verify-printer (event)
+  (begin-event "Enter the interactive proof check with:")
+  (infix-print (cadr event))
+  (end-event))
+
+(defun accumulated-persistence-printer (term)
+  (print-default-command-header)
+  (if (cadr term)
+      (pprinc "Activate statistics gathering.")
+      (pprinc "De-activate statistics gathering."))
+  (no-tab-command-trailer))
+
+(defun show-accumulated-persistence-printer (term)
+  (print-default-command-header)
+  (cond ((equal (cadr term) :frames)
+	 (pprinc "Display statistics ordered by frames built."))
+	((equal (cadr term) :tries)
+	 (pprinc "Display statistics ordered by times tried."))
+	((equal (cadr term) :ratio)
+	 (pprinc "Display statistics ordered by the ratio of frames built to times tried."))
+	(t nil))
+  (no-tab-command-trailer))
+
+(defun brr-printer (term)
+  (print-default-command-header)
+  (if (cadr term)
+      (pprinc "Enable the breaking of rewrite rules.")
+      (pprinc "Disable the breaking of rewrite rules."))
+  (no-tab-command-trailer))
+
+(defun monitor-printer (term)
+  (let ((form (cadr term))
+	(flag (caddr term)))
+    (if (and (consp form) (equal (car form) 'quote))
+	(setq form (cadr form)))
+    (if (and (consp flag) (equal (car flag) 'quote))
+	(setq flag (cadr flag)))
+    (print-default-command-header)
+    (pprinc "Monitor: ")
+    (print-rune-string form)
+    (cond ((equal flag t))
+	  (t (pprinc " when ")
+	     (infix-print-term flag)))
+    (no-tab-command-trailer)))
+
+(define-command-printer monitored-runes "Print monitored runes.")
+
+(defun unmonitor-printer (term)
+  (let ((form (cadr term)))
+    (if (and (consp form) (equal (car form) 'quote))
+	(setq form (cadr form)))
+    (print-default-command-header)
+    (pprinc "Un-monitor: ")
+    (cond ((equal form :all) (pprinc "all monitored runes."))
+	  (t (print-rune-string form)
+	     (pprinc ".")))
+    (no-tab-command-trailer)))
+
+(defun add-macro-alias-printer (term)
+  (print-default-command-header)
+  (pprinc "Let the macro name ")
+  (print-bare-function-name (cadr term))
+  (pprinc " be an alias for the function ")
+  (print-bare-function-name (caddr term))
+  (pprinc ".")
+  (no-tab-command-trailer))
+
+(defun remove-macro-alias-printer (term)
+  (print-default-command-header)
+  (pprinc "Remove the alias from the macro ")
+  (print-bare-function-name (cadr term))
+  (pprinc ".")
+  (no-tab-command-trailer))
+
+(define-command-printer logic "Enter logic mode.")
+(define-command-printer program "Enter program mode.")
+
+(defun set-compile-fns-printer (term)
+  (print-default-command-header)
+  (if (cadr term)
+      (pprinc "New functions will be compiled after their defun.")
+      (pprinc "New functions will not be compiled after their defun."))
+  (no-tab-command-trailer))
+
+(defun set-ignore-ok-printer (term)
+  (print-default-command-header)
+  (cond ((null (cadr term))
+	 (pprinc "Disallow unused formals and locals."))
+	((eq (cadr term) t)
+	 (pprinc "Allow unused formals and locals."))
+	((eq (cadr term) :warn)
+	 (pprinc "Allow unused formals and locals, but print warning.")))
+  (no-tab-command-trailer))
+
+(define-command-printer set-invisible-fns-alist "Setting the invisible fns alist.")
+
+(defun set-irrelevant-formals-ok-printer (term)
+  (print-default-command-header)
+  (cond ((null (cadr term))
+	 (pprinc "Disallow irrelevant formals in definitions."))
+	((eq (cadr term) t)
+	 (pprinc "Allow irrelevant formals in definitions."))
+	((eq (cadr term) :warn)
+	 (pprinc "Allow irrelevant formals in definitions, but print warning.")))
+  (no-tab-command-trailer))
+
+(defun set-measure-function-printer (term)
+  (print-default-command-header)
+  (pprinc "Set the default measure function to be ")
+  (print-bare-function-name (cadr term))
+  (pprinc ".")
+  (no-tab-command-trailer))
+
+(defun set-verify-guards-eagerness-printer (term)
+  (print-default-command-header)
+  (cond ((equal (cadr term) 0)
+	 (pprinc "No guard verification unless :verify-guards is t."))
+	((equal (cadr term) 1)
+	 (pprinc "Verify guards, if supplied."))
+	((equal (cadr term) 2)
+	 (pprinc "Verify guards, unless :verify-guards is NIL.")))
+  (no-tab-command-trailer))
+
+(defun set-well-founded-ordering-printer (term)
+  (print-default-command-header)
+  (pprinc "Set the default well-founded relation to be ")
+  (print-bare-function-name (cadr term))
+  (pprinc ".")
+  (no-tab-command-trailer))
+
+;; TABLE
+
+(defun table-printer (term)
+  ;; (table tests 1 '(...))               ; set contents of tests[1] to '(...)
+  ;; (table tests 25)                     ; get contents of tests[25]
+  ;; (table tests)                        ; return table tests as an alist
+  ;; (table tests nil nil :clear)         ; clear table tests
+  ;; (table tests nil (foo 7) :clear)     ; set table tests to (foo 7)
+  ;; (table tests nil nil :guard)         ; fetch the table guard
+  ;; (table tests nil nil :guard term)    ; set the table guard
+  (print-default-command-header)
+  (let ((table (nth 1 term))
+	(i (nth 2 term))
+	(value (nth 3 term))
+	(op (nth 4 term))
+	(guard (nth 5 term)))
+    (cond ((null (cddr term))
+	   (ppformat "Return table, ")
+	   (infix-print-term1 table)
+	   (ppformat ", as an alist."))
+	  ((null (cdddr term))
+	   (infix-print-term1 table)
+	   (pprinc "[")
+	   (infix-print-term1 i)
+	   (pprinc "]"))
+	  ((null (cdddr (cdr term)))
+	   (infix-print-term1 table)
+	   (pprinc "[")
+	   (infix-print-term1 i)
+	   (pprinc "]")
+	   (math-space 1)
+	   (pprinc ":=")
+	   (math-space 1)
+	   (infix-print-term1 value)
+	   (pprinc ";"))
+	  ((null op)
+	   (message (format nil "Unknown table operation ~s" term)))
+	  ((equal op :clear)
+	   (cond ((null value)
+		  (ppformat "Clear table, ")
+		  (infix-print-term1 table)
+		  (ppformat "."))
+		 (t (ppformat "Set elements of table, ")
+		    (infix-print-term1 table)
+		    (ppformat " to ")
+		    (infix-print-term1 value)
+		    (pprinc "."))))
+	  ((equal op :guard)
+	   (cond ((null guard)
+		  (ppformat "Fetch guard of table, ")
+		  (infix-print-term1  table)
+		  (ppformat "."))
+		 (t
+		  (ppformat "Set guard of table, ")
+		  (infix-print-term1 table)
+		  (ppformat ", to ")
+		  (infix-print-term1 guard)
+		  (pprinc "."))))
+	  (t (message (format nil "Unknown table operation ~s" term)))))
+  (no-tab-command-trailer))
+
+;; We would like to put this at the top, but the functions need to be defined first.
+
+(setq *event-printer-alist*
+      (append
+       *event-printer-alist*
+       (list
+	(list 'defaxiom (function defaxiom-printer))
+	(list 'defcong (function defcong-printer))
+	(list 'defconst (function defconst-printer))
+	(list 'defcor (function defcor-printer)) ;gone
+	(list 'defequiv (function defequiv-printer))
+	(list 'deflabel (function deflabel-printer))
+	(list 'defdoc   (function defdoc-printer))
+	(list 'defevaluator (function defevaluator-printer))
+	(list 'defmacro (function defmacro-printer))
+	(list 'defpkg (function defpkg-printer))
+	(list 'defrefinement (function defrefinement-printer))
+	(list 'defstub (function defstub-printer))
+	(list 'deftheory (function deftheory-printer))
+	(list 'defthm (function defthm-printer))
+	(list 'defun (function defun-printer))
+	(list 'defun-sk (function defun-sk-printer))
+	(list 'define (function defun-printer)) ;mks&mk specific
+	(list 'in-package (function in-package-printer))
+	(list 'rebuild (function rebuild-printer))
+	(list 'encapsulate (function encapsulate-printer))
+	(list 'verify-guards (function verify-guards-printer))
+	(list 'verify-termination (function verify-termination-printer))
+
+	;; Books
+
+	(list 'include-book (function include-book-printer))
+	(list 'certify-book (function certify-book-printer))
+	(list 'certify-book! (function certify-book-printer))
+
+	;; History.
+
+	;; (list 'ubt (function ubt-printer))
+	;; (list 'pbt (function ignore-printer))
+	;; (list 'pc  (function pc-printer))
+	;; (list 'pcb (function pcb-printer))
+	;; (list 'pe  (function pe-printer))
+
+	;; OTHER
+
+	(list 'in-theory (function in-theory-printer))
+	(list 'local (function local-printer))
+	(list 'mutual-recursion (function mutual-recursion-printer))
+	(list 'defuns (function defuns-printer))
+	(list 'ld (function ld-printer))
+
+	(list 'comp (function comp-printer))
+	(list 'checkpoint-forced-goals (function checkpoint-forced-goals-printer))
+	(list 'puff (function puff-printer))
+	(list 'puff* (function puff*-printer))
+	(list 'reset-ld-specials (function reset-ld-specials-printer))
+	(list 'set-cbd (function set-cbd-printer))
+
+	(list 'set-guard-checking (function set-guard-checking-printer))
+	(list 'ubt (function ubt-printer))
+	(list 'ubt! (function ubt-printer))
+	(list 'retrieve (function retrieve-printer))
+	(list 'skip-proofs (function skip-proofs-printer))
+	(list 'accumulated-persistence (function accumulated-persistence-printer))
+	(list 'show-accumulated-persistence (function show-accumulated-persistence-printer))
+	(list 'brr (function brr-printer))
+	(list 'monitor (function monitor-printer))
+	(list 'unmonitor (function unmonitor-printer))
+	(list 'add-macro-alias (function add-macro-alias-printer))
+	(list 'remove-macro-alias (function remove-macro-alias-printer))
+	(list 'set-compile-fns (function set-compile-fns-printer))
+	(list 'set-ignore-ok (function set-ignore-ok-printer))
+	(list 'set-irrelevant-formals-ok (function set-irrelevant-formals-ok-printer))
+	(list 'set-measure-function (function set-measure-function-printer))
+	(list 'set-verify-guards-eagerness (function set-verify-guards-eagerness-printer))
+	(list 'set-well-founded-ordering (function set-well-founded-ordering-printer))
+
+	(list 'table (function table-printer))
+
+	)))
+
+(defparameter *save-event-printer-alist* *event-printer-alist*)
+
+(defun get-event-printer (sym)
+  (let ((a (assoc sym *event-printer-alist*)))
+    (cond (a (cadr a))
+          (t (function default-event-printer)))))
+
+;;                          KEYWORD PRINTERS
+
+(defvar *keyword-printer-alist* nil)
+
+;; Argument to keyword printers is a pair (key . value)
+
+(defun get-keyword-printer (sym)
+  (let ((a (assoc sym *keyword-printer-alist*)))
+    (cond (a (cadr a))
+          (t (function default-keyword-printer)))))
+
+(defun default-keyword-printer (pair)
+  (ppformat " ~a is ~a" (car pair) (cdr pair)))
+
+(defun standard-co-keyword-printer (pair)
+  ;; "foo.out"
+  (ppformat " standard output to ~a" (cdr pair)))
+
+(defun proofs-co-keyword-printer (pair)
+  ;; "proofs.out"
+  (ppformat " proof output to ~a" (cdr pair)))
+
+(defun current-package-keyword-printer (pair)
+  ;; 'acl2
+  (let ((name (if (equal (car (cdr pair)) 'quote)
+		  (cadr (cdr pair))
+		  (cdr pair))))
+    (ppformat " in the package ~a" name)))
+
+(defun ld-skip-proofsp-keyword-printer (pair)
+  ;; 'include-book
+  (cond ((null (cdr pair))
+	 (ppformat " doing proofs"))
+	((equal (cdr pair) t)
+	 (ppformat " skipping termination proofs"))
+	((equal (cdr pair) '(quote include-book))
+	 (ppformat " assuming proofs in included books"))
+	((equal (cdr pair) '(quote include-book-with-locals))
+	 (ppformat " assuming proofs in included books and executing local events"))
+	((equal (cdr pair) '(quote initialize-acl2))
+	 (ppformat " skipping local proofs"))
+	(t nil)))
+
+(defun ld-redefinition-action-keyword-printer (pair)
+  ;; nil
+  (cond ((null (cdr pair))
+	 (ppformat " redefinition prohibited"))
+	(t (let ((a (car (cdr pair)))
+		 (b (cdr (cdr pair))))
+	     (cond ((eq a ':query)
+		    (ppformat " query on redefinition "))
+		   ((eq a ':warn)
+		    (ppformat " warn on redefinition"))
+		   ((eq a ':doit)
+		    (ppformat " redefinition ok"))
+		   (t			; :warn! :query!
+		    (ppformat " redefinition ~a" a)))
+	     (cond ((eq b ':erase)
+		    (ppformat " erase properties on redefinition "))
+		   ((eq a ':overwrite)
+		    (ppformat " overwrite properties on redefinition"))
+		   (t
+		    (ppformat " redefinition properties ~a" a)))))))
+
+(defun ld-prompt-keyword-printer (pair)
+  ;; t
+  (cond ((null (cdr pair))
+	 (ppformat " no prompt"))
+	((eq (cdr pair) t)
+	 (ppformat " default prompt"))
+	(t
+	 (ppformat " prompt function = ~a" (cdr pair)))))
+
+(defun ld-keyword-aliases-keyword-printer (pair)
+  ;; pair = (:ld-keyword-aliases '((:q 0 q-fn) (:e 0 exit-acl2-macro)))
+  (let ((x (cdr pair)))
+    (if (equal (car x) 'quote)
+	(setq x (cadr x)))
+    (ppformat " define keyword aliases (")
+    (sloop for tail on x do
+	   (cond ((cddr tail)
+		  (ppformat "~s = ~a of arity ~d, "
+			    (car (car tail)) (caddr (car tail)) (cadr (car tail))))
+		 ((cdr tail)
+		  (ppformat "~s = ~a of arity ~d and "
+			    (car (car tail)) (caddr (car tail)) (cadr (car tail))))
+		 (t (ppformat "~s = ~a of arity ~d"
+			      (car (car tail)) (caddr (car tail)) (cadr (car tail))))))
+    (ppformat ")")))
+
+(defun ld-pre-eval-filter-keyword-printer (pair)
+  ;; :all
+  (cond ((null (cdr pair)))
+	((equal (cdr pair) ':all)
+	 (ppformat " every form read is evaled"))
+	((equal (cdr pair) ':query)
+	 (ppformat " user queried whether form read is evaled"))
+	(t nil)))
+
+(defun ld-pre-eval-print-keyword-printer (pair)
+  ;; nil
+  (if (cdr pair)
+      (ppformat " forms read are printed")
+      (ppformat " forms read are not printed")))
+
+(defun ld-post-eval-print-keyword-printer (pair)
+  ;; :all
+  (cond ((null (cdr pair))
+	 (ppformat " results are not printed"))
+	((equal (cdr pair) t)
+	 (ppformat " results are printed"))
+	((equal (cdr pair) ':command-conventions)
+	 (ppformat " conditionally print error triples"))
+	(t nil)))
+
+(defun ld-evisc-tuple-keyword-printer (pair)
+  ;; '(alist nil nil level length)
+  (let (value)
+    (cond ((null (cdr pair)) (setq value nil))
+	  ((not (consp (cdr pair))) (setq value (cdr pair)))
+	  ((equal (car (cdr pair)) 'quote) (setq value (cadr (cdr pair))))
+	  (t (setq value (cdr pair))))
+    (cond ((null value)
+	   (ppformat " print results fully"))
+	  (t (let ((alist (cadr value))
+		   (level (car (cdddr value)))
+		   (length (car (cdr (cdddr value)))))
+	       (ppformat " eviscerate results (level = ~d, length = ~d)" level length)
+	       (if alist
+		   (progn (ppformat "whose cars are in (" )
+			  (sloop for tail on alist do
+				 (cond ((cddr tail)
+					(ppformat"~a, " (car (car tail))))
+				       ((cdr tail)
+					(ppformat " ~a, and" (car (car tail))))
+				       (t (ppformat " ~a)" (car (car tail)))))))))))))
+
+(defun ld-error-triples-keyword-printer (pair)
+  ;; t
+  (cond ((null (cdr pair))
+	 (ppformat " errors printed as triples"))
+	((equal (cdr pair) t)
+	 (ppformat " errors roll back to state before call"))
+	(t nil)))
+
+(defun ld-error-action-keyword-printer (pair)
+  ;; :return
+  (cond ((null (cdr pair)))
+	((equal (cdr pair) ':continue)
+	 (ppformat " continue after errors"))
+	((equal (cdr pair) ':return)
+	 (ppformat " return after errors"))
+	((equal (cdr pair) ':error)
+	 (ppformat " signal errors"))
+	(t nil)))
+
+(defun ld-query-control-alist-keyword-printer (pair)
+  ;; nil
+  (cond ((null (cdr pair))
+	 (ppformat " handle queries interactively"))
+	((equal (cdr pair) 't)
+	 (ppformat " queries default to first accepted response"))
+	(t
+	 (ppformat "queries default according to ~s"  (cdr pair)))))
+
+(defun ld-verbose-keyword-printer (pair)
+  ;; nil
+  (cond ((null (cdr pair))
+	 (ppformat"verbose mode off "))
+	(t
+	 (ppformat " verbose mode on"))))
+
+(defparameter *keyword-printer-alist*
+  (list (list ':standard-co (function standard-co-keyword-printer))
+	(list ':proofs-co (function proofs-co-keyword-printer))
+	(list ':current-package (function current-package-keyword-printer))
+	(list ':ld-skip-proofsp (function ld-skip-proofsp-keyword-printer))
+	(list ':ld-redefinition-action (function ld-redefinition-action-keyword-printer))
+	(list ':ld-prompt (function ld-prompt-keyword-printer))
+	(list ':ld-keyword-aliases (function ld-keyword-aliases-keyword-printer))
+	(list ':ld-pre-eval-filter (function ld-pre-eval-filter-keyword-printer))
+	(list ':ld-pre-eval-print (function ld-pre-eval-print-keyword-printer))
+	(list ':ld-post-eval-print (function ld-post-eval-print-keyword-printer))
+	(list ':ld-evisc-tuple (function ld-evisc-tuple-keyword-printer))
+	(list ':ld-error-triples (function ld-error-triples-keyword-printer))
+	(list ':ld-error-action (function ld-error-action-keyword-printer))
+	(list ':ld-query-control-alist (function ld-query-control-alist-keyword-printer))
+	(list ':ld-verbose (function ld-verbose-keyword-printer))))
+
+
+;                           COPY COMMENTS
+
+;; MKS Tue Jul 13 1993
+;; Make ;- comments and BAR-COMMENTs followed by a dash appear in
+;; a formatted (in Latex, verbatim) environment.
+
+(defparameter *comment-environment* nil)
+
+(defparameter *comment-format* 'smith)	
+
+(defparameter *comment-semi-net* nil)
+(defparameter *comment-lb-net* nil)
+
+;; We use this two stage template/eval kludge so that if the template can 
+;; be used to reset the variable after the user has defined these variables.
+
+;; Note a problem with this flexibility.  In some contexts we need to format 
+;; special characters and in others we don't.  Thus in LaTeX, in a Verbatim
+;; we don't need to quote `_', but in running text we do need to quote it.
+
+(defparameter *comment-environment-mapping-template*
+  (quote `((text     "" "")
+	   (format   ,*begin-format-env*   ,*end-format-env*)
+           (verbatim ,*begin-verbatim-env* ,*end-verbatim-env*)
+           (emphasis ,*begin-emphasis-env* ,*end-emphasis-env*)
+	   (comment  ,*begin-comment-env*  ,*end-comment-env*)
+	   (section ,*begin-section-env*   ,*end-section-env*))))
+
+(defparameter *comment-environment-mapping*
+  (eval *comment-environment-mapping-template*))
+
+(defparameter *saved-whitespace* nil)
+
+(defun print-saved-whitespace ()
+  (sloop for c in *saved-whitespace*
+	 do (if (stringp c) (pprinc c) (pwrite-char c)))
+  (setq *saved-whitespace* nil))
+
+(defun wrap-up-copy-comments ()
+  ;; MOD - X
+  (end-environment)
+  (print-saved-whitespace)
+  (throw 'copy-comments nil))
+
+(defun begin-environment (env)
+  (setq *comment-environment* env)
+  (ppformat
+           (or (cadr (assoc env *comment-environment-mapping*)) "")))
+
+(defun end-environment ()
+  (if *comment-environment*
+      (ppformat (or (caddr (assoc *comment-environment*
+				  *comment-environment-mapping*))
+		    "")))
+  (setq *comment-environment* nil))
+
+(defun end-environment-and-write (c)
+  (end-environment)
+  (pwrite-char c))
+
+(defun pop-environment-write-and-push (string)
+  (let ((saved-env *comment-environment*))
+    (if (not saved-env)
+        (pprinc string)
+        (progn (end-environment)
+               (pprinc string)       
+               (begin-environment saved-env)))))
+
+(defun end-environment-if-not (env)
+  (if (not (equal *comment-environment* env))
+      (end-environment)))
+
+(defun white-space-string-p (s)
+  (let ((x t))
+    (sloop for i from 0 to (- (length s) 1) 
+             do (setq x (and x (member (char s i) *white-space*))))
+    x))
+
+(defun insert-newpage ()
+  (pop-environment-write-and-push (pformat nil "~%~a~%" *newpage*)))
+
+;; (defparameter *format-tag-char* #\~)
+
+(defun check-environment-and-write (env ch)
+
+  ;; Note: Latex causes an error on an empty VERBATIM environment, so we watch out
+  ;; for that as a special case.  Also, Latex forbids control-l in a verbatim
+  ;; environment, so we watch out for that, too.
+
+  ;; Thus, we forbid any empty environments, and we always pull a page break 
+  ;; out of the current environment.
+
+  ;; First, end an existing environment if it is not ENV.
+
+  (end-environment-if-not env)
+
+  (cond ((not *comment-environment*)    ; We are in no environment.  Enter one.
+         (cond ((and ch (not (member ch *white-space*)))
+		;; Assuming *saved-whitespace* can't intersect
+		;; characters handled by (handle-special-chars-in-string ch)
+                (print-saved-whitespace)
+                (begin-environment env))
+
+;; Does this work? Printing of saved whitespace complicated by the
+;; verbatim restrictions of latex.  I.e., can't have an empty verbatim.
+
+
+               ((and ch (eql ch #\Page)) ;; MOD 1/96 (equal env 'verbatim)
+                ;;(setq *saved-whitespace*
+                ;;    (append *saved-whitespace*
+                ;;            (list (format nil "~%~a~%" *newpage*))))
+		(ppformat t "~%~a~%" *newpage*))
+               (ch (setq *saved-whitespace*
+                        (append *saved-whitespace* (list ch)))))))
+  ;; Tabs
+  (cond ((and (equal env 'verbatim)
+              (eql ch #\Tab) 
+              (not *reported-tabs*))
+         (setq *reported-tabs* t)
+         (pformat *terminal-io* 
+                  "WARNING: about tabs!~%We note the presence of a tab ~
+                  in a comment that we are copying~%into a verbatim ~
+                  environment.  Tabs will be treated just like ~%single spaces ~
+                  by Latex.  Consider removing all tabs, e.g., ~%with the ~
+                  Emacs command M-x untabify.~%")))
+
+  ;; Print it or not, checking #\Page.
+  (cond (*saved-whitespace*)
+        ((and (eql ch #\Page) (equal env 'verbatim))
+         (end-environment)
+         (ppformat "~%~a~%"  *newpage*)
+         (begin-environment env))               
+
+        (ch
+	 ;; Switched (pwrite-char ch)
+	 (handle-special-chars-in-string ch))))
+
+(defun unread-chars (l stream)
+  (sloop for c in l do (unread-char c stream)))
+
+(defun read-char-in-comment ()
+       (let ((c (read-char *standard-input* nil a-very-rare-cons)))
+         (cond ((eq c a-very-rare-cons)
+                ;; EOF.  We are no longer in a comment.  
+                ;; Exit whatever environment we are in, which will be either
+                ;; verbatim, format, or none.
+                (wrap-up-copy-comments))
+               (t c))))
+
+(defun copy-comments-read-net (net)
+  ;; Returns (env char), where env is the environment to 
+  ;; enter and char is nil or a char to unread.
+  ;; Net is cdr of a net whose car = #\;
+  ;; Have already read a #\; 
+  ;;
+  ;; Test (progn (read-char)(COPY-COMMENTS-READ-NET *comment-semi-net*))
+  ;;
+  (let* ((subnet (car net))
+         (action (cadr net))
+	 ;; on EOF does a throw out once it cleans up.
+         (c (read-char-in-comment)) 
+         (branch (assoc c subnet)))
+    (cond ((null branch) 
+           (unread-char c *standard-input*)
+           (list (car action) (cadr action)))
+          (t (copy-comments-read-net (cdr branch))))))
+
+(defvar number-deep nil "Measure of depth of imbedding in \#\| \|\# comments")
+
+(defun normalize-lb-comment-line (str action)
+  (let ((beg (search "#|" str))
+	(end (search "|#" str)))
+    (cond ((and beg end)
+	   (cond ((< beg end)
+		  (normalize-lb-comment-line
+		   (concatenate 'string
+				(subseq str 0 beg)
+				(subseq str (+ beg 2) end)
+				(subseq str (+ end 2)))
+		   action))
+		 (t (format-comment-string (subseq str 0 end) action)
+		    (decf number-deep 1)
+		    (cond ((= number-deep 0)
+			   (end-environment)
+			   (unread-chars (coerce (subseq str (+ end 2)) 'list)
+					 str))
+			  (t (normalize-lb-comment-line (read-line *standard-input*) action))))))
+	  (beg (incf number-deep 1)
+	       (format-comment-string (subseq str 0 beg) action)
+	       (normalize-lb-comment-line (subseq str (+ beg 2)) action))
+	  (end (format-comment-string (subseq str 0 end) action)
+	       (decf number-deep 1)
+	       (cond ((= number-deep 0)
+		      (end-environment)
+		      (subseq str (+ end 2)))
+		     (t (normalize-lb-comment-line (subseq str (+ end 2)) action))))
+	  (t (format-comment-string str action)
+	     (normalize-lb-comment-line (read-line *standard-input*) action)))))
+
+(defun format-comment-string (line mode)
+  (if (and *acl2-format-comments* (search "~" line))
+      (let ((pair (acl2-parse-string line)))
+	(if (car pair)			;failed
+	    nil
+	    (setq line (cdr pair)))))
+  (let ((max (- (length line) 1)))
+    (sloop for i from 0 to max
+	   do (let ((ch (aref line i)))
+		(cond ((eql ch #\Page) (insert-newpage))
+		      ;; switched (pwrite-char ch)
+		      (*comment-environment* (handle-special-chars-in-string ch))
+		      (t (check-environment-and-write mode ch)))))
+    (if (> max 0)
+	(if (not (char-equal (aref line max) #\Newline))
+	    (pwrite-char #\Newline)
+	    nil)
+	(pwrite-char #\Newline))
+    nil))
+
+(defun copy-comments ()
+
+; This function tries to sneak up to the next top-level open parenthesis,
+; parsing all of the Lisp comments up till there.
+; NOTE:  Jul 13 93 MKS 
+; Random atoms, numbers, strings and characters are treated as if they were in
+; comments.  And are printed in a FORMAT environment.
+; NOTE:  Nov 30 94 MKS 
+; This sneaking up doesn't work quite the way we would like. If we have
+; a comment line, followed by a blank line, followed by (foo ..) then we
+; put out the formatted comment line, followed by a blank line, followed
+; by a close-environment, followed by the formatted (foo ..).
+
+  (let (*comment-environment*)
+    (catch 'copy-comments
+      (sloop
+       for ch = (read-char-in-comment)
+
+; The top level loop for simulating the skimming of whitespace and comments
+; that READ would perform to get to the next open parenthesis.
+
+       (case ch
+
+; Semicolon starts a comment.  
+; We use *COMMENT-SEMI-NET* to determine how to format the comment based on the 
+; immediately following characters.  This is user-setable to produce
+; running text, a format environment (honors spaces and newlines, but probably
+; does not produce a fixed width font), a verbatim environment (like format, but
+; fixed width font), an emphasis environment (typically italics), or a title
+; environment (like a section name).
+
+         (#\;
+	  ;; Do one line.
+          (let ((action (copy-comments-read-net *comment-semi-net*)))
+            (check-environment-and-write (car action) (cadr action))
+	    (format-comment-string (read-line *standard-input*) (car action))))
+
+; #\| starts a comment.  
+; As above, we use the *comment-lb-net* to determine what formatting action to take.
+; \|# ends one. 
+
+         (#\#
+          (setq ch (read-char-in-comment))
+          (cond ((not (eql ch #\|))
+                 (error"Do not know how to handle #~s while copying at the top level." ch)))
+          (let ((action (copy-comments-read-net *comment-lb-net*)))
+            
+            ;; The following may not put us into an env if (cadr
+            ;; action) is whitespace.
+
+            (check-environment-and-write (car action) (cadr action))
+
+            ;; We ignore formatting changes within imbedded #| |# comments.
+            ;; They are stuck with whatever the outermost comment
+            ;; decreed.
+
+	    (setq number-deep 1)
+	    (let* ((line (read-line *standard-input*))
+		   (rest (normalize-lb-comment-line line (car action))))
+	      (cond ((and rest (not (string-equal rest "")))
+		     ;; Sep 22 95 MKS reversed order of the 2 forms below.
+		     ;; Wrap-up throws out of copy-comments.
+		     (unread-chars (nreverse (coerce rest 'list))
+				   *standard-input*)
+		     (wrap-up-copy-comments))))))
+
+         ;; A raw ^L at the top level, not in a comment.
+         (#\Page (end-environment)
+          (ppformat "~%~a~%"  *newpage*))
+
+	 (#\Newline
+	  (end-environment)
+	  (print-saved-whitespace)
+	  (pwrite-char ch))
+         (#\(
+          (unread-char #\( *standard-input*)
+          (wrap-up-copy-comments))
+	 ;; Handle keywords like parenthesized forms, because they may
+	 ;; need to read their arguments.
+         (#\:
+          (unread-char #\: *standard-input*)
+          (wrap-up-copy-comments))
+         (otherwise ;; switched (pwrite-char ch)
+	  ;; MOD -  Sep 21 95 MKS 
+	  ;; Added the following:
+	  (print-saved-whitespace)
+	  (handle-special-chars-in-string ch)
+	  ))))))
+
+
+;;--------------------------------------------------------------------------------
+;
+;                       COMMENT FORMATS
+;
+
+(defparameter *comment-format-alist* nil)
+(defparameter *comment-format* nil)
+
+(defun update-alist (al key value)
+  (cond ((not (consp al)) (list (cons key key value)))
+        ((eq key (caar al)) (cons (cons key value) (cdr al)))
+        (t (cons (car al) (update-alist (cdr al) key value)))))
+
+(defun define-comment-format (n format)
+  ;; Last call to this sets *comment-format*.
+  ;; Can be overruled by 
+  ;;  1. assigning directly to *comment-format*,
+  ;;  2. calling (setup-comment-format format-name), or 
+  ;;  3. calling infix-setup with the appropriate arguments.
+  (if (not (check-comment-character-net format))
+      (format *terminal-io* "~%Ill formed definition for comment format ~a" n)
+      (progn 
+	(setq *comment-format* n)
+	(cond ((assoc n *comment-format-alist*)
+	       (setq  *comment-format-alist* (update-alist *comment-format-alist* n format)))
+	      (t (setq *comment-format-alist*
+		       (cons (cons n format) *comment-format-alist*)))))))
+
+(defun setup-comment-format (&optional n)
+  (cond ((and n (assoc n *comment-format-alist*))
+	 ;; A named format.
+	 (setq *comment-format* n))
+	((and n *comment-format*)
+	 ;; Not defined.  Use existing setting.
+	 (format *terminal-io*
+		 "~%No comment format named ~a.  Left as ~a." n *comment-format*))
+	(n (setq *comment-format* 'smith)
+	   (format *terminal-io*
+		   "~%No comment format named ~a.  Defaluting to ~a." n *comment-format*))
+        ((null *comment-format*)
+         (cond ((eq *infix-op-location* 'FRONT)
+                (setq *comment-format* 'smith))    
+               ((eq *infix-op-location* 'BACK)
+                (setq *comment-format* 'boyer))    
+               (t (setq *comment-format* 'smith))))
+        ((assoc *comment-format* *comment-format-alist*))
+	(*comment-format-alist* 
+	 (setq *comment-format* (caar *comment-format-alist*))
+	 (format *terminal-io* "~%Defaluting to first format in alist, ~a." *comment-format*))
+        (t ;; Should never get here.
+	 (format *terminal-io* "~%*** No comment formats defined!!! ***")))
+  (compute-comment-character-net *comment-format*)
+  ;; We have side-effected *comment-semi-net* and *comment-lb-net*
+  ;; Update mapping info AFTER users theory file loaded.
+  (setq *comment-environment-mapping* (eval *comment-environment-mapping-template*)))
+
+(defun check-comment-character-net (l)
+  (if (null l)
+      (format *terminal-io* "*COMMENT-FORMAT* is not present in *COMMENT-FORMAT-ALIST*."))
+  (if (not (assoc #\; l))
+      (format *terminal-io* "Selected comment format should include a list labelled \"\;\"."))
+  (if (not (assoc #\# l))
+      (format *terminal-io* "Selected comment format  should include a list labelled \"\#\"."))
+  ;; Each branch is of the form (string flag environment [echo-character])
+  (check-comment-character-net2 l))
+
+(defun check-comment-character-net2 (l)
+  (cond ((null l) t)
+        ((and (listp l)
+              (listp (car l))
+              (characterp (caar l))
+              (every
+	       (function
+		(lambda (branch)
+		  (if (check-comment-character-branch branch)
+		      t
+		      (format *terminal-io* "Ill-formed branch in *COMMENT-FORMAT-ALIST*.~
+                                                       ~%~a" branch))))
+	       (cadr (car l)))
+              (let ((top (cddr (car l))))
+                (and (or (equal (car top) 't) (null (car top)))
+                     ;; Must be known environment.
+                     (assoc (cadr top) *comment-environment-mapping*)
+                     (or (null (cddr top)) (characterp (caddr top))))))
+         ;; Do the other one, if there.
+         (check-comment-character-net2 (cdr l)))
+        (t nil)))
+
+(defun check-comment-character-branch (b)
+  (and (listp b)
+       (> (length b) 2)
+       (stringp (car b))
+       (or (equal (cadr b) 't) (null (cadr b)))
+       ;; Must be known environment.
+       (assoc (caddr b) *comment-environment-mapping*)
+       (or (null (cdddr b))
+           (characterp (cadddr b)))))
+
+(defun compute-comment-character-net (name)
+  (let ((l (cdr (assoc name  *comment-format-alist*))))
+    (let ((net (assoc #\; l)))
+      (setq *comment-semi-net*
+            (if net
+                (cdr (compute-net -1 (car net) (cadr net) (caddr net) (cdddr net)))
+                nil)))
+    (let ((net (assoc #\# l)))
+      (setq *comment-lb-net*
+            (if net
+                (cdr (compute-net -1 (car net) (cadr net) (caddr net) (cdddr net)))
+                nil)))))
+
+(defun compute-net (n char net skip-one-blank-p default)
+  (list char
+        (append (if skip-one-blank-p
+                    `((#\  nil ,default))
+                    nil)
+                (compute-branches (+ n 1) net))
+        default))
+
+(defun compute-branches (n net)
+  (cond ((null net) nil)
+        (t (merge-net (compute-branch n (car net))
+                      (compute-branches n (cdr net))))))
+
+(defun compute-branch (n branch)
+  ;; branch is of the form (string flag . default)
+  (let ((string (car branch))
+        (flag (cadr branch))
+        (default (cddr branch)))
+  (cond ((> n (length string)) nil)
+        ((= n (length string))
+         (if flag
+             `(#\  nil ,default)
+             nil))
+        (t (append (list (char string n)
+                         (list (compute-branch (+ n 1) branch)))
+                   (if (= (+ n 1) (length string)) (list default) nil))))))
+
+(defun merge-net (branch net)
+  ;; All branches of net begin with a unique character.
+  ;; As does the result.
+  (cond ((null net) (list branch))
+        ((char= (car branch) (caar net))
+         (let ((def1 (caddr branch))
+               (def2 (caddr (car net))))
+           (cons
+	    (list (car branch)
+		  (merge-net (caadr branch) (cadr (car net)))
+		  (cond ((equal def1 def2) def1)
+			((and def1 def2)
+			 (format *terminal-io*
+				 "Your comment network is in conflict ~a ~a." branch (car net))
+			 def1)
+			(def1 def1)
+			(t def2)))
+	    (cdr net))))
+        (t (cons (car net) (merge-net branch (cdr net))))))
+
+(define-comment-format 'boyer
+  '((#\; (("\\"   t   text))
+     nil verbatim #\;)
+    (#\# (("\\"   t   text))
+     nil verbatim)))
+
+(define-comment-format 'smith
+  '((#\; (("\;"   t   text   )
+          ("\#"   t   comment )
+          ("\;\;" t   verbatim )
+          ("\\"   t   text     )
+          ("-"    t   format   )
+          ("+"    t   verbatim )
+          ("!"    t   emphasis )
+          ("\;\\" nil   text     #\;)
+          ("\;-"  nil   format   #\;)
+          ("\;+"  nil   verbatim #\;)
+          ("\;!"  nil   emphasis #\;))
+     t text)
+    (#\# (("\\"   t   text     )
+          ("\#"   t   comment  )
+          ("-"    t   format   )
+          ("\;"   t   verbatim ))
+     t text )))
+
+
+(define-comment-format 'CL
+  '((#\; (("\;"   t    format )
+          ("\;\;" t    text   )
+          ("\;\;\;" t  section)
+
+          ("\\"   t   text     )
+          ("-"    t   format   )
+          ("+"    t   verbatim )
+          ("!"    t   emphasis )
+          ("\;\\" nil   text     #\;)
+          ("\;-"  nil   format   #\;)
+          ("\;+"  nil   verbatim #\;)
+          ("\;!"  nil   emphasis #\;))
+     t emphasis)
+    (#\# (("\\"   t   text     )
+          ("-"    t   format   )
+          ("\;"   t   verbatim ))
+     t text )))
+
+(setup-comment-format 'cl)
+
+;; End of comment stuff.
+
+(defun infix-form (form &key ((:print-case *print-case*) :downcase))
+  ;; We cannot recover well from this case since we don't
+  ;; know where we are.  All of the I/O that provides that info
+  ;; is in the top level loop.  So these inner forms are just out of luck.
+  (let ((*top-parens-eliminable* t)
+        (*print-pretty* nil)
+	;; (*saved-tab-stack* *tab-stack*)
+	)
+    ;; (cond ((catch 'taboverflow
+    ;;              (let ((*tabs-in* 1))
+    ;;                (or *do-not-use-tabs* (begin-tabbing))
+    ;;                (infix-print-term1 form)
+    ;;                (or *do-not-use-tabs* (end-tabbing))
+    ;;                nil))
+    ;;            (pformat *terminal-io*
+    ;; 		    "~%Sorry. Exceeded tabbing limit (1). ~a needs hand massaging.~%"
+    ;; 		    (car form))
+    ;; 	   (setq *tab-stack* *saved-tab-stack*)
+    ;; 	   (newline)))
+    (let ((*tabs-in* 1))
+      (or *do-not-use-tabs* (begin-tabbing))
+      (infix-print-term1 form)
+      (or *do-not-use-tabs* (end-tabbing))
+      nil)))
+
+(defun infix-event (form &key ((:print-case *print-case*) :downcase))
+  ;; We cannot recover well from this case since we don't
+  ;; know where we are.  All of the I/O that provides that info
+  ;; is in the top level loop.  So these inner forms are just out of luck.
+  (let ((*top-parens-eliminable* t)
+        (*print-pretty* nil))
+    ;; (cond ((catch 'taboverflow
+    ;;              (let ((*tabs-in* 1))
+    ;;                (funcall (get-event-printer (car form)) form)
+    ;;                nil))
+    ;;            (pformat *terminal-io*
+    ;; 		    "~%Sorry. Exceeded tabbing limit (2). ~a needs hand massaging.~%"
+    ;; 		    (car form))
+    ;; 	   (newline)))
+    (let ((*tabs-in* 1))
+      (funcall (get-event-printer (car form)) form)
+      nil)))
+
+(defparameter *last-mode* nil)
+
+(defparameter *infix-trace* nil)
+
+(defun current-directory ()
+  ;; This is somewhat redundant.  
+  ;; That is (probe-file file) should equal 
+  ;; (probe-file (concatenate 'string (current-directory) file))
+  ;; But we let *current-directory* also be set by the input file.
+  (truename "./"))
+
+;; This may be set by the function above or based on the directory of the input file.
+(defparameter *current-directory* nil)
+
+(defun probe-theory (fl)
+  (let ((name (concatenate 'string (pathname-name fl) "-theory")))
+    (or (probe-file (make-pathname :name name
+				   :type "lisp" :defaults fl))
+	(probe-file (make-pathname :name name
+				   :type "lisp"
+				   :directory (pathname-directory *current-directory*)
+				   :defaults fl))
+	(probe-file (make-pathname :name name
+				   :type "lisp"
+				   :directory (pathname-directory *infix-directory*)
+				   :defaults fl)))))
+
+;; Check that *infix-directory* we can find at least a latex and scribe theory.
+(eval-when (load eval)
+ (if (not (and (probe-theory "scribe") (probe-theory "latex")))
+     (format *terminal-io* "~%Seem to be missing theory of scribe or latex or both.~%")))
+
+(defun type-file-name (file type &optional force)
+  ;;if extension = nil, return file.
+  ;;if file already has type and force = nil, return file.
+  (cond ((null type) file)
+	((and (not force) (pathname-type file)) file)
+	(t (make-pathname :type type :defaults file))))
+
+(defvar *default-chars-wide* 77)
+
+(defun directory-or-current (fl)
+  (let ((dir (directory-namestring fl)))
+    (cond ((null dir) (current-directory))
+	  ((not (equal dir "")) dir)
+	  (t (current-directory)))))
+
+(defun probe-cert-for-packages (fl)
+  (let ((cert (probe-file (make-pathname :type "cert" :defaults fl)))
+	doit)
+    (if cert
+	(progn 
+	  (format t "Checking ~s for defpackage forms.~%" cert)
+	  (with-open-file
+	   (*standard-input* cert :direction :input)
+	   (sloop for form = (read *standard-input* nil a-very-rare-cons nil)
+		  until (or (eq form a-very-rare-cons)
+			    (eq form :end-portcullis-cmds))
+		  do
+		  (cond ((eq form :begin-portcullis-cmds)
+			 (setq doit t))
+			((and doit (consp form) (eq (car form) 'defpkg))
+			 (if (not (find-package (cadr form)))
+			     (make-package (cadr form))))
+			(t nil))))))))
+
+(defun infix-file (fl &key ((:print-case *print-case*) :downcase)
+                      (mode nil)
+                      (chars-wide *default-chars-wide*)
+                      (comment *nq-default*))
+
+  (let ((*current-directory* (directory-or-current fl))
+	(fl-root (pathname-name fl))
+	*tab-stack*)
+    (cond ((and mode (string= mode *infix-mode*))
+           (format t "~%Processing in ~a mode.~%" mode))
+          ((stringp mode)
+           (setq *infix-mode* mode)
+           (format t "~%Entering ~a mode.~%" *infix-mode*)
+           (load-infix-init-file))
+          (mode
+           (setq *infix-mode* (string mode))
+           (format t "~%Entering ~a mode.~%" *infix-mode*)
+           (load-infix-init-file))
+          ((probe-theory fl-root)
+           (setq *infix-mode* (pathname-name fl-root))
+           (format t "~%Entering ~a mode.~%" *infix-mode*)
+           (load-infix-init-file))
+          ((null *infix-mode*)
+           (cond ((y-or-n-p "Enter Latex mode? ")
+                  (setq *infix-mode* "latex"))
+                 ((y-or-n-p "Enter Scribe mode? ")
+                  (setq *infix-mode* "scribe"))
+                 (t (setq *infix-mode* nil)))
+           (if *infix-mode*
+               (progn (format t "~%Entering ~a mode.~%" *infix-mode*)
+                      (load-infix-init-file))))
+          (t (format t "~%Remaining in ~a mode.~%" *infix-mode*)))
+
+; infix-file takes a root file name, e.g., foo, reads the file foo.lisp,
+; which we suppose has been previously checked by LD, and creates the
+; file foo.tex, which the user can then run through Latex, etc.  By default, we
+; lowercase all variable and function symbols, but the user can override this
+; with the keyword parameter.
+
+; If the keyword comment is given as true, then we first generate fl.nqxxx and then
+; invoke nqfmt2fmt, generating fl.xxx (.tex or .mss).
+
+    ;; Update comment information AFTER users theory file loaded.
+    (setup-comment-format)
+
+    (if *infix-mode*
+        (let ((infl  (type-file-name fl infix-input-file-type))  ; ".lisp"
+              ;; .mss, .tex, .nqmss, .nqtex
+              (outfl (type-file-name fl (fmtfile-extension *infix-mode* comment) t))  
+              (a-very-rare-cons (cons nil nil))
+              (*print-pretty* nil)
+              (*top-parens-eliminable* t)
+              (*readtable* (copy-readtable nil))
+              (*reported-tabs* nil)
+              (*infix-loc* 0)
+              (*left-margin* 0)
+              (*rightmost-char-number* chars-wide)
+              (count 1)
+              inpos)
+	  (probe-cert-for-packages fl)
+          (smash-infix-readtable)
+	  
+          (with-open-file
+           (*standard-input* infl :direction :input)
+           (with-open-file
+
+; We do *all* of our printing of terms to *standard-output*, giving princ only
+; one argument.
+
+            (*standard-output* outfl :direction :output :if-exists :rename-and-delete)
+
+; The formatting system opening.
+
+            (ppformat *standard-prelude*)
+            (sloop for form = (progn (copy-comments)
+				     ;; Set this here so we don't rewrite preceding comment, 
+				     ;; if tabs overflow.
+				     (setq inpos (file-position *standard-input*))
+				     (readx *standard-input* nil a-very-rare-cons nil))
+
+; We remember where we are in the output file as part of our mechanism for
+; recovering from the very small finiteness of the Latex tabbing mechanism.  We
+; will rewrite to the current position and start printing in verbatim mode with
+; PPR if we exceed the Latex tabbing mechanism.
+
+                     for outpos = (file-position *standard-output*)
+                     until (eq form a-very-rare-cons)
+                     do
+                     ; (ppformat "\\filbreak %\\item~%")
+                     (cond ((or (eq (car form) 'comment)
+                                (cond ((catch 'taboverflow
+                                         (let ((*tabs-in* 1))
+                                           (if *infix-trace*
+                                               (format *terminal-io* "~% ~a " (car form)))
+                                           ;; Let the user know we are making some
+					   ;; kind of progress, every 10 events.
+                                           (if (= count 10)
+					       (progn (format *terminal-io* ".")
+						      (setq count 1))
+                                               (incf count))
+                                           (funcall (get-event-printer (car form)) form))
+                                         nil)
+				       (pformat *terminal-io*
+						"~%Warning: Tab limit reached in event ~a~
+                                                 ~%Hand massaging required.~%"
+					     (or (and (consp form) (cdr form) (cadr form))
+						 (car form)))
+                                       t)))
+                            ;; If taboverflow, go back to where we started printing and
+                            ;; print over the previous stuff.  In the 'commment case our
+                            ;; position is unchanged.
+                            (file-position *standard-output* outpos)
+			    (setq *tab-stack* nil)
+                            (begin-environment 'verbatim)
+                            (let ((stop (file-position *standard-input*)))
+                              (file-position *standard-input* inpos)
+                              (sloop while (< (file-position *standard-input*) stop)
+                                       do (check-environment-and-write 'verbatim
+								       (read-char *standard-input*))))
+                            (end-environment))
+                           (t nil)))
+            (ppformat *standard-postlude*)))
+          (if comment
+              (nqfmt2fmt fl)
+              outfl))
+        (format t "~%No mode specified (e.g. Latex or Scribe), aborting.~%"))))
+
+(defun load-obj-or-lisp (file)
+  (let ((object (make-pathname :type "o" :defaults file)))
+    (cond ((and (probe-file object)
+		(> (file-write-date object) (file-write-date file)))
+	   (load object))	  
+	  ((probe-file file) (load file))
+	  (t (error (format nil "~%No theory or init file mathcing ~f~%" file))))))
+
+;; (defun load-obj-or-lisp (file)
+;;   (let* ((name2 (if (member 'sparc *features*)
+;; 		    (concatenate 'string (pathname-name file) "-sparc")
+;; 		    (concatenate 'string (pathname-name file) "-sun")))
+;; 	 (file2   (probe-file (make-pathname :name name2 :defaults file)))
+;;          (object  (probe-file (make-pathname :type "o" :defaults file)))
+;;          (object2 (if file2 (probe-file (make-pathname :type "o" :defaults file2)))))
+;;     (cond ((and object2 (> (file-write-date object2) (file-write-date file2)))
+;; 	   (load object2))
+;; 	  (file2 (load file2))
+;; 	  ((and object (> (file-write-date object) (file-write-date file)))
+;; 	   (load object))	  
+;; 	  ((probe-file file) (load file))
+;; 	  (t (error (format nil "~%No theory or init file mathcing ~f~%" file))))))
+
+(defun load-theory-or-init (dir)
+  (let* ((initfile   (make-pathname :name (concatenate 'string *infix-mode* "-init")
+				    :type "lisp"
+				    :directory (pathname-directory dir)))
+         (theoryfile (make-pathname :name (concatenate 'string *infix-mode* "-theory")
+				    :type "lisp"
+				    :directory (pathname-directory dir))))
+    ;; We assume that, if present, the -theory file loads the -init file.
+    (cond ((probe-file theoryfile) (load-obj-or-lisp theoryfile) t)
+          ((probe-file initfile)   (load-obj-or-lisp initfile) t)
+          (t nil))))
+
+(defun load-infix-init-file ()
+  (clean-up-everything)
+  (cond ((null *infix-mode*)
+         (format t "~%Failed to initialize.  *infix-mode* is NIL.~%"))
+        ((not (stringp *infix-mode*))
+         (format t "~%Failed to initialize.~
+                    ~%*infix-mode* (~a) is not a string.~%" *infix-mode*))
+        ((load-theory-or-init *current-directory*))
+        ((load-theory-or-init *infix-directory*))
+        (t (format t "~%Failed to initialize.  No init or theory file in ~a nor ~a.~%"
+                   *current-directory* *infix-directory*)
+           (setq *infix-mode* nil))))
+
+(defun fmtfile-extension (mode comment)
+  (cond ((and *mode-extension* (stringp *mode-extension*))
+         (if comment (concatenate 'string "nq" *mode-extension*) *mode-extension*))
+        ((string= mode "latex")
+         (if comment "nqtex" "tex"))
+        ((string= mode "scribe")
+         (if comment "nqmss" "mss"))
+        (t (if comment "nqnq" "nq"))))
+
+(defun fmt2fmt-extension (remove! mode)
+  (cond (remove! "stripped")
+        ((and *mode-extension* (stringp *mode-extension*))
+         (concatenate 'string "nq" *mode-extension*))
+        ((string= mode "latex")  "nqtex")
+        ((string= mode "scribe") "nqmss")
+        (t "nqnq")))
+
+(defvar nqread-default-white-space '(#\Space #\Newline #\Tab #\Page #\Return))
+(defvar nqread-default-normal-clause-enders '(#\. #\! #\? #\, #\; #\:))
+(defvar nqread-default-break-chars '(#\( #\) #\` #\' #\" #\; #\,))
+
+(defparameter nqread-white-space nqread-default-white-space)
+(defparameter nqread-normal-clause-enders nqread-default-normal-clause-enders)
+(defparameter nqread-break-chars nqread-default-break-chars)
+
+(defun acl2-read-preserving-whitespace-error ()
+  (error "A character or an integer or an Acl2 symbol was expected at location ~a of input."
+         (file-position *standard-input*)))
+
+(defun acl2-read-preserving-whitespace ()
+
+; This function does the READing right after a ! command.  This
+; function is almost the same as read-preserving-whitespace.  It is
+; different only because of the peculiar problem of trailing
+; punctuation marks.  We sometimes stop the reading before Common Lisp
+; would.
+
+; In processing ! commands, we call READ on the following text.  If
+; the text starts with an open parenthesis or string-quote, it is
+; clear where the READing should stop.  However, if a mere symbol or
+; number follows a ! command, then when READing the symbol we treat
+; an exclamation mark, colon, question mark, or period that is
+; followed by whitespace as a punctuation mark, not as part of the
+; symbol that is to be READ.  The other ordinary English clause ending
+; punctuation characters (comma and semicolon) already naturally
+; terminate a READ, as do parentheses, quotation marks, and
+; whitespace.
+
+; Example.  When we do a READ while processing a ! command under
+; nqtex2tex, we have to decide what to do about text such as
+
+;    !tnil.
+
+; The question is, does the period belong to the token to be read, or
+; is it just some user punctuation?  We take the attitude that the
+; answer is punctuation.  Now, this attitude is a bit arbitrary.  nil.
+; is a legal Common Lisp symbol.  Unfortunately it is ALSO a legal Acl2 symbol.
+; But we are just going to assume that it is atypical.  And likewise for 
+; `foo.bar'.  We also run into problems reading things like
+; xxx.@end{text}@begin{format}@tabclear{}.  This is a fine atom as far as
+; ACL2 is concerned. Likewise 
+; xxx.\begin{verbatim}\hfill
+; So the text-formatting -init file will need to extend nqread-normal-clause-enders
+; to account for this.
+
+; One might ask, who cares?  The reason we care is that nil, and other 
+; symbols on *atom-alist*, get printed specially.  For example, nil is 
+; printed in bold, not italics.  If we read nil. as one symbol, it would 
+; come out in intalics because nil. is not on *atom-alist*.
+
+; The idea of fiddling with READ so that it is `smart' about not
+; reading a trailing punctuation character is weird.  But then,
+; calling READ in the middle of Tex file is weird, too.  We have found from
+; experience that it is very hard to write sentences that have
+; whitespace after every symbol.  We want to be able to write things
+; like !tnil, and !tnil.  So here is the general procedure for how far
+; we READ after a ! command.  When we say READ below, we really mean
+; read-preserving-whitespace.
+
+; We peek at the first nonwhitespace character after the ! command,
+; and we consider the cases on this character.
+
+; If it is ( or " we simply call READ, knowing that upon encountering
+; the closing " or ) READ will not look at any trailing punctuation.
+
+; If it is ' or ` we recursively read further with this function and
+; then quote or backquote the result.  This is so that `foo. will come
+; out right.
+
+; Otherwise, we call READ on the string consisting of all of the
+; characters up to but not including the first (a) whitespace, (b)
+; terminating readmacro Common Lisp character, i.e., ()`'"";,, or (c)
+; normal English clause ending character, i.e., .!?:, that is followed
+; by a whitespace.
+
+; Known ambiguity.  Although periods are permitted at the ends of
+; numbers in Acl2 syntax, we treat them as ends of sentences, if they
+; are followed by white space.  Thus in reading !t5. , the read
+; would not pick up the period.  So the period would appear in the
+; final text.  It is hard to see whether this is a bug, a feature, or
+; a problem that simply never arises.
+
+; Known ambiguity.  Because the quotation mark is a legal character
+; in Acl2 symbols, a minor question arises about the handling of
+; a terminal question mark in an Acl2 symbol; we treat it as punctuation.
+; Thus !qfoo? will come out as `foo'? rather than `foo?'.
+
+; All this peeking stuff doesn't work really correctly if there are
+; comments in the way, so we adopt this rule: don't put comments in
+; expressions after ! commands.  Typically, this function is called
+; inside of a comment.  If the text to be read extends over a line and
+; the next line begins with a ; character, you may not get at all what
+; you want because the text on the line after the ; will be skipped.
+
+  (case (peek-char t *standard-input*)
+        ((#\( #\") (read-preserving-whitespace *standard-input*))
+        (#\'
+         (read-char *standard-input*)
+         (list 'quote (acl2-read-preserving-whitespace)))
+        (#\`
+         (read-char *standard-input*)
+         (list *infix-backquote* (acl2-read-preserving-whitespace)))
+        (otherwise 
+	 (let ((*package* *user-package*))
+         (read-from-string
+          (coerce
+           (nconc
+            (prog (c ans c2)
+                  loop
+                  (setq c (peek-char nil *standard-input* nil a-very-rare-cons))
+                  (cond ((or (eq c a-very-rare-cons)
+                             (member c nqread-white-space)
+                             (member c nqread-break-chars))
+                         (cond ((null ans)
+                                (acl2-read-preserving-whitespace-error)))
+                         (return (nreverse ans)))
+                        ((member c nqread-normal-clause-enders)
+                         (read-char *standard-input*)
+                         (setq c2 (peek-char nil *standard-input* nil a-very-rare-cons))
+                         (cond ((or (member c2 nqread-white-space)
+                                    (eq c2 a-very-rare-cons))
+                                (unread-char c *standard-input*)
+                                (cond ((null ans)
+                                       (acl2-read-preserving-whitespace-error)))
+                                (return (nreverse ans)))
+                               (t (push c ans))))
+                        ((member c '(#\| #\; #\\))
+                         (acl2-read-preserving-whitespace-error))
+                        (t (read-char *standard-input*)
+                           (push c ans)))
+                  (go loop))
+
+; Sticking on this extra space is not strictly necessary.  We do it to
+; work around a bug in AKCL 1-605.
+
+            (list #\Space))
+           'string))))))
+
+(defparameter nqtex2tex-chars
+  (coerce "eipqtv" 'list))
+
+;             NQFMT2FMT
+
+(defun nqfmt2fmt (fl &key
+                  ((:print-case *print-case*) :downcase)
+                  ((:left-margin *left-margin*) 5)
+                  (just-remove-! nil))
+
+; Copies the file fl.nqxxx file to the file fl.xxx file, replacing Acl2 forms
+; preceded by a two character sequence starting with an exclamation mark with
+; the results described below.  If an exclamation mark is not followed by one
+; of these special characters, then the following form is preserved unchanged,
+; and the exclamation mark and the character following it are preserved, too.
+
+; Although we may extend this set of replacement commands, we *promise* to give
+; special meanings only to alphabetic characters after !.  Thus we promise
+; never to give !!  a replacement effect. 
+
+; In every case, for one of the replacement characters, upper or lower case has
+; the same effect.
+
+; !Bform, prints form in bold.
+
+; !Eev, where ev is an Acl2 event form, e.g., (defun foo (x) 3), results in
+; conventional notation for ev.  We may introduce line breaks via tabbing commands.
+; Mnemonic: E -- think Event.
+
+; !Ifoo, where foo is a symbol, results in foo, but with with formatting sensitive
+; characters quoted.  For example, in TeX, !Ia$b would result in a\$b.  
+; Mnemonic: I -- think Identity.
+
+; !Pfm, where fm is an Acl2 term, e.g., (plus x y), results in conventional
+; mathematical notation for fm.  May introduce line breaks via tabbing.
+; Mnemonic: P -- think Pretty print.
+
+; !Qfn, where fn is a symbol, results in fn surrounded by single gritches,
+; after formatting sensitive characters have been quoted, e.g., !qfoo results in
+; `foo' in TeX.  Useful for distinguishing function symbols from other words in a
+; sentence, since function symbols appear in Roman.  
+; Mnemonic: Q -- think Quoted.
+
+; !Tfm, where fm is an Acl2 term, results in conventional mathematical
+; notation for fm, but without any line breaks.  
+; Mnemonic: T -- think Term.
+
+; !Vfoo means that foo is printed as is, but in typewriter font, and with
+; special characters quoted.  
+; Mnemonic: V -- think Verbatim.
+
+; ! followed by anything else is left alone, along with the exclamation mark.
+
+; One can certainly use nqfmt2fmt on the result of running infix-file, but one
+; must do so deliberately by first running infix-file, then renaming the
+; resulting file, say foo.tex, to be foo.nqtex, and then running nqfmt2fmt.
+; More convenient is to run infix-file with the :comment keyword parameter set to t,
+; which causes infix-file first to generate a .nqtex file and second to run
+; nqfmt2fmt on that file.
+
+; If the :just-remove-! keyword is t, then a file named root.stripped is
+; created, with all of our special ! commands options removed.
+
+; Implementation note.  In all the cases we treat explicitly, the characters
+; after !? are read with the Lisp function READ-PRESERVING-WHITESPACE, which
+; is just the same as READ except that it doesn't gratuitously consume whitespace
+; at the end of a READ.
+
+; Warning: Because we use a relative of READ to obtain the forms immediately
+; after the two character exclamation commands, the user must beware that if a
+; form to be read extends for more than a line, and if a semicolon (comment
+; character) is encountered on the next line, say at the beginning, READ will
+; skip that line from the semicolon on, which may not be what the user intends.
+; Thus it can be safer to use the #\| ... \|# construct for comments containing
+; !, especially if one is in the habit of using the Emacs command M-x fill
+; paragraph to rearrange paragraphs that begin with the comment delimiter
+; semicolon.
+
+  (let ((infl (type-file-name fl (fmt2fmt-extension just-remove-! *infix-mode*) t))
+        (*print-pretty* nil)
+        (orig-readtable (copy-readtable nil))
+        (outfl (type-file-name fl (fmtfile-extension *infix-mode* nil) t))
+        (a-very-rare-cons (cons nil nil))
+        (count 1)
+        (*readtable* (copy-readtable nil)))
+    (smash-infix-readtable)
+    (with-open-file
+     (*standard-input* infl :direction :input)
+     (with-open-file
+      (*standard-output* outfl :direction :output :if-exists :rename-and-delete)
+      (sloop for c = (read-char *standard-input* nil a-very-rare-cons)
+	     (let (form)
+	       (cond ((catch 'taboverflow
+			(cond ((eq c a-very-rare-cons) (return-from nqfmt2fmt outfl))
+			      ;; The Latex indexing routines may insert new exclamation points!!!
+			      ((eql c #\\)
+			       (cond ((skip-index-entries) nil)
+				     ;; I am inserting a gigantic hack here because
+				     ;; I can't figure out a more principled, simple 
+				     ;; way to get the effect I want in LaTeX.
+				     ;; The problem is that at the end of a tabbing
+				     ;; environment we often have two lines of the form:
+				     ;;   ....  \\
+				     ;;   \end{tabbing}
+				     ;; which causes the event formatted in the tabbing
+				     ;; env to appear to be followed by two blank lines
+				     ;; rather than one.
+				     ((adjust-tabbing-env) nil)
+				     (t (pwrite-char c))))
+			      ((eql c #\!)
+			       (let ((c (read-char *standard-input* nil a-very-rare-cons)))
+				 (cond ((eq c a-very-rare-cons)
+					(pwrite-char #\!)
+					(return-from nqfmt2fmt outfl)))
+				 (case c
+				   ((#\B #\b)
+				    (or just-remove-!
+					(let ((term (acl2-read-preserving-whitespace)))
+					  (setq form term)
+					  (bold-sym-printer term))))
+				   ((#\C #\c)
+				    (or just-remove-!
+					(let ((term (acl2-read-preserving-whitespace)))
+					  ;(handler-case 
+					  (eval term)
+					   ;(error () (pwrite-char #\!)
+						;     (pwrite-char c)
+						;     (prin1 term)))
+					  )))
+				   ((#\E #\e)
+				    (or just-remove-!
+					(let ((term (acl2-read-preserving-whitespace)))
+					  (setq form term)
+					  (infix-event term))))
+				   ((#\I #\i)
+				    (or just-remove-!
+					(let ((term (acl2-read-preserving-whitespace)))
+					  (print-atom term))))
+				   ((#\P #\p)
+				    (or just-remove-!
+					(let ((term (acl2-read-preserving-whitespace)))
+					  (setq form term)
+					  (infix-form term))))
+				   ((#\Q #\q)
+				    (or just-remove-!
+					(let ((term (acl2-read-preserving-whitespace)))
+					  (print-bare-function-name term))))
+				   ((#\S #\s)
+				    (or just-remove-!
+					(let ((rest (acl2-read-preserving-whitespace)))
+					  (sectionize rest just-remove-!))))
+				   ((#\T #\t)
+				    (or just-remove-!
+					(let ((term (acl2-read-preserving-whitespace))
+					      (*do-not-use-tabs* t))
+					  (infix-form term))))
+				   ((#\V #\v)
+				    (or just-remove-!
+					(let* ((*readtable* orig-readtable)
+					       (term (acl2-read-preserving-whitespace))
+					       (*do-not-use-tabs* t))
+					  (quote-printer1 term))))
+				   ((#\Space #\Tab #\Newline)
+				    (pwrite-char #\!)
+				    (pwrite-char c))
+				   (otherwise
+				    (or just-remove-!
+					(pformat *terminal-io*
+						 "Surprising character after ! ~a.~%" c))
+				    (pwrite-char #\!)
+				    (pwrite-char c)))))
+			      ;; Let the user know we are making some kind 
+			      ;; of progress, every 60 lines
+			      ((eql c #\Newline)
+			       (if (= count 60)
+				   (progn (format *terminal-io* "-") (setq count 1))
+				   (incf count))
+			       (pwrite-char c))
+			      (t (pwrite-char c)))
+			nil)
+			(pformat *terminal-io*
+				 "~%Sorry. Exceeded tabbing limit (2). 
+We can't handle this large a form in running text.  ~a needs hand massaging.~%"
+				 (car form))
+			(newline))))
+		   )))))
+                              
+(defvar balanced-parens '((#\( . #\))
+			  (#\[ . #\])
+			  (#\{ . #\})))
+
+(defun sectionize (rest just-remove-!)
+  ;; sleazy hack to make sections independent of mode (scribe or tex).
+  (let (left right)
+    (setq rest (intern (string-upcase rest)))
+    (cond ((equal rest 'ection)
+	   (setq left (read-char *standard-input* nil a-very-rare-cons))	 
+	   (setq right (cdr (assoc left balanced-parens)))
+	   (cond ((null right) (pprinc "section") (pwrite-char left))
+		 (t (pprinc *begin-section-env*)
+		    (sloop for c = (read-char *standard-input* nil a-very-rare-cons)
+			   until (equal c right) 
+			   do (pwrite-char c))
+		    (pprinc *end-section-env*))))
+	  ((equal rest 'ubsection) 
+	   (setq left (read-char *standard-input* nil a-very-rare-cons))	 
+	   (setq right (cdr (assoc left balanced-parens)))
+	   (cond ((null right) (pprinc "subsection") (pwrite-char left))
+		 (t (pprinc *begin-subsection-env*)
+		    (sloop for c = (read-char *standard-input* nil a-very-rare-cons)
+			   until (equal c right) 
+			   do (pwrite-char c))
+		    (pprinc *end-subsection-env*))))
+	  (t (or just-remove-!
+		 (pformat *terminal-io* "Surprising string after !s ~s.~%" rest))
+	     (pwrite-char #\!)
+	     (pwrite-char #\s)
+	     (pprinc rest)))))
+
+(defun skip-index-entries ()
+  ;; We are looking at a backslash. In Tex mode we need to skip to the end 
+  ;; of the entry, because we may add !'s.  In Scribe mode this is just NIL.
+  nil)
+
+(defun adjust-tabbing-env ()
+  ;; We are looking at a backslash. In Tex mode we may need to replace 
+  ;;   ....  \\
+  ;;   \end{tabbing}
+  ;; with
+  ;;   ....  
+  ;;   \end{tabbing}
+  ;; NOTE: this will only work if NQFMT2FMT is run.
+  ;; In Scribe mode this is just NIL.
+  nil)
+
+
+;                        INFIX SETTINGS
+
+; This function should be called by the <mode>-init file, or may be called by
+; the <mode>-theory file to override the <mode>-init settings.
+
+(defun infix-settings
+  (&key (mode                   nil p-mode)                  ; string ["SCRIBE","latex",...]
+        (extension              nil p-extension)              ; string ["MSS","tex"]
+        (op-location            nil p-op-location)            ; ['FRONT,'BACK]
+        (comment-format         nil p-comment-format)         ; ['SMITH,'boyer]
+        (format-!-in-comments   nil p-format-!-in-comments)   ; [T,nil]
+        (acl2-format-comments   nil p-acl2-format-comments)   ; [T,nil]
+        (acl2-format-doc-strings nil p-acl2-format-doc-strings) ; [T,nil]
+        (eliminate-top-parens   nil p-eliminate-top-parens)   ; [T,nil]
+        (eliminate-inner-parens nil p-eliminate-inner-parens) ; [T,nil]
+        (no-index               nil p-no-index)               ; [t,NIL]
+        (no-index-calls         nil p-no-index-calls))        ; [t,NIL,l]
+
+  (if p-mode           (setq *infix-mode* mode))
+  (if p-extension      (setq *mode-extension* extension))
+  (if p-op-location    (setq *infix-op-location* op-location))
+  (if p-comment-format (setup-comment-format comment-format))
+  (if p-format-!-in-comments   (setq *nq-default* format-!-in-comments))
+  (if p-acl2-format-comments   (setq *acl2-format-comments* acl2-format-comments))
+  (if p-acl2-format-doc-strings (setq *acl2-format-doc-strings* acl2-format-doc-strings))
+  (if p-eliminate-top-parens   (setq *top-parens-eliminable* eliminate-top-parens))
+  (if p-eliminate-inner-parens (setq *top-parens-eliminable-default* eliminate-inner-parens))
+  (if p-no-index
+      (setq *do-not-index* no-index))
+  (if p-no-index-calls
+      (cond ((consp no-index-calls)
+             (setq *do-not-index-calls-of* (append no-index-calls *do-not-index-calls-of*))
+             (setq *do-not-index-calls* nil))
+            (t  (setq *do-not-index-calls* no-index-calls)))))
+
+(defun will-will-not (x)
+  (if x "will" "will not"))
+
+(defun show-infix-settings ()
+  (format *terminal-io* "~%Expecting a .~a file to be mapped to .~a file to be formatted by ~a."
+          infix-input-file-type *mode-extension* *infix-mode*)
+  (format *terminal-io* "~%Multiline infix ops will be printed at the ~a of the line." *infix-op-location*)
+  (format *terminal-io* "~%Comment format is ~a." *comment-format*)
+  (format *terminal-io* "~%!formatting ~a be in effect." (will-will-not *nq-default*))
+  (format *terminal-io* "~%Topmost parens ~a be suppressed." (will-will-not *top-parens-eliminable*))
+  (format *terminal-io* "~%Inner parens ~a be suppressed." (will-will-not *top-parens-eliminable-default*))
+  (format *terminal-io* "~%Index ~a be created." (will-will-not (not *do-not-index*)))
+  (format *terminal-io* "~%Calls ~a be indexed." (will-will-not (not *do-not-index-calls*))))
+
+(defun help-infix-settings ()
+  (format *terminal-io* "~%To see current settings use (SHOW-INFIX-SETTINGS).
+To change settings use INFIX-SETTINGS and supply the keyword arguments
+for settings you wish to modify. Defaults in caps.~%")
+  (format *terminal-io* "~%:mode           : string - formatting style [\"SCRIBE\",\"latex\",...]")
+  (format *terminal-io* "~%:extension      : string - output file extension [\"MSS\",\"tex\"]")
+  (format *terminal-io* "~%:op-location    : ['FRONT, 'back]
+                - Multiline infix operators will be printed at the front 
+                - or back of the line according to this setting.")
+  (format *terminal-io* "~%:comment-format : ['SMITH, 'boyer, 'cl] - Comment format")
+  (format *terminal-io* "~%:no-index: [t,NIL] - Index will/will not be created")
+  (format *terminal-io* "~%:no-index-calls : [t,NIL,1ist]
+                - Calls will/will not be indexed.  If a list,
+                - these functions will not be indexed.")
+  (format *terminal-io* "~%:format-!-in-comments    : [T, nil] - !formatting in effect.")
+  (format *terminal-io* "~%:acl2-format-comments    : [T, nil] - acl2 comment formatting.")
+  (format *terminal-io* "~%:acl2-format-doc-strings : [T, nil] - acl2 formatting doc strings.")
+  (format *terminal-io* "~%:eliminate-top-parens    : [T, nil] - Topmost parens suppressed.")
+  (format *terminal-io* "~%:eliminate-inner-parens  : [T, nil] - Inner parens suppressed."))
+
+                                   
+;                             DEFINITION BY EXAMPLES
+
+; Anyone extending the syntax by hand rather than by use of one of the make...
+; functions ought also to add something to this list of examples to illustrate
+; the new syntax.
+
+(defun functify (l)
+  ;; Removes redundant elements from an alist.
+  (sloop for tail on l with ans
+           do (cond ((null (assoc (car (car tail)) ans))
+                     (push (car tail) ans)))
+           finally (return (nreverse ans))))
+
+(defvar *infix-test-directory*
+  (concatenate 'string *infix-directory* "test/"))
+
+(defun scrunch (l)
+  (sloop for tail on l unless (member (car tail) (cdr tail))
+	 collect (car tail)))
+
+(defun print-examples (&optional mode)
+
+; Illustrates the current syntax via a brief sample document.
+
+  (cond (mode
+	 (cond ((and (stringp mode)
+		     (or (equal mode "latex")
+			 (equal mode "scribe")))
+		(setq *infix-mode* mode)
+		(format t "~%Entering ~a mode.~%" *infix-mode*)
+		(load-infix-init-file))
+	       (t (error (format nil "Unknown mode ~s" mode)))))
+	((stringp *infix-mode*)
+         (format t "~%Entering ~a mode.~%" *infix-mode*)
+         (load-infix-init-file))
+        ((null *infix-mode*)
+         (cond ((y-or-n-p "Enter Latex mode? ")
+                (setq *infix-mode* "latex"))
+               ((y-or-n-p "Enter Scribe mode? ")
+                (setq *infix-mode* "scribe"))
+               (t (setq *infix-mode* nil)))
+	 (if *infix-mode*
+	     (progn (format t "~%Entering ~a mode.~%" *infix-mode*)
+		    (load-infix-init-file))))
+        (t (format t "Remaining in ~a mode." *infix-mode*)))
+
+  
+
+  (let ((*print-pretty* nil)
+        (*print-case* :downcase))
+    (with-open-file
+     (*standard-output* (type-file-name "infix-examples"
+					(fmt2fmt-extension nil *infix-mode*) t)
+                        :direction :output
+                        :if-exists :rename-and-delete)
+     (ppformat *example-prelude* *infix-mode*)
+     (sloop for form in (functify *wired-in-infix-examples*)
+              do (let ((*do-not-use-tabs* t))
+                   (pprinc *begin-item*)
+                   (quote-printer1 form)
+                   (ppformat " is printed as ~%~%")
+                   (infix-form form)
+                   (ppformat ".~%")
+                   (pprinc *end-item*))
+              (ppformat "~%"))
+     (pprinc *begin-item*)
+     (ppformat "The remaining symbols that are printed specially are
+described in the following table.")
+     (pprinc *end-item*)
+     (pprinc *end-enumerate-env*)
+     (ppformat "~%~%")
+     (let ((*tab-stack* t)
+	   (table-number 1)
+	   (example-number 1))
+       ;; need to set *tab-list* non-nil to ensure (newline) works properly.
+       (ppformat *begin-example-table* table-number)
+       (sloop for form in
+              (append (sloop for pair in (functify *atom-alist*)
+			     collect (car pair))
+                      (sloop for name in (scrunch *constant-ops*)
+			     collect (list name))
+                      (sloop for name in (scrunch *infix-ops*)
+			     collect (list name 'x 'y))
+                      (sloop for pair in (functify *negative-constant-table*)
+			     collect (list 'not (list (car pair))))
+                      (sloop for pair in (functify *negative-infix-table*)
+			     collect (list 'not (list (car pair) 'x 'y)))
+                      (sloop for name in (scrunch *unary-prefix-ops*)
+			     collect (list name 'x))
+                      (sloop for pair in (functify *negative-unary-prefix-table*)
+			     collect (list 'not (list (car pair) 'x)))
+                      (sloop for name in (scrunch *unary-suffix-ops*)
+			     collect (list name 'x))
+                      (sloop for pair in (functify *negative-unary-suffix-table*)
+			     collect (list 'not (list (car pair) 'x)))
+                      (sloop for name in (scrunch *unary-abs-ops*)
+			     collect (list name 'x))
+                      (sloop for pair in (functify *prefix-multiple-ops*)
+			     collect (cons (car pair)
+					   (sloop for i from 1 to (cdr pair) collect
+						  (intern (format nil "X~a" i)))))
+                      (sloop for pair in (functify *suffix-multiple-ops*)
+			     collect (cons (car pair)
+					   (sloop for i from 1 to (cdr pair) collect
+						  (intern (format nil "X~a" i)))))
+                      (sloop for pair in (functify *infix-multiple-ops*)
+			     collect (cons (car pair)
+					   (sloop for i from 1 to (1+ (cdr pair)) collect
+						  (intern (format nil "X~a" i))))))
+              do (let ((*do-not-use-tabs* t))
+		   (cond ((> example-number *example-table-size*)
+			  (ppformat *end-example-table*)
+			  (ppformat *begin-example-table* table-number)
+			  (setq example-number 1)))
+                   (quote-printer1 form)
+                   (pprinc *column-separator*)
+                   (infix-form form)
+		   (new-tab-row nil)
+		   (line-return)
+		   (setq table-number (+ 1 table-number))
+		   (setq example-number (+ 1 example-number))
+                   (setq *infix-loc* *left-margin*)))
+       (ppformat *end-example-table*))
+     (pprinc *example-postlude*))
+    (nqfmt2fmt "infix-examples")))
+
+
+; The following should be modified to interact with the vaiables that set 
+; parens printing.  In particular, this seems to be the piece of precedence that
+; is most easily screwed up.
+
+;                                      NOT
+
+; The following code is for the special handling of NOT, which involves diving
+; into the term negated to turn a predicate into one that has a slash through
+; it.  We advise that the casual user not touch this.
+
+(defun not-printer (term)
+  (let (x)
+    (cond ((atom (cadr term))
+           (default-unary-prefix-printer term *neg-str*))
+          ((setq x (assoc (car (cadr term)) *negative-constant-table*))
+           (pprinc (cadr x)))
+          ((setq x (assoc (car (cadr term)) *negative-infix-table*))
+           (default-infix-printer (cadr term) (cadr x)))
+          ((setq x (assoc (car (cadr term)) *negative-unary-prefix-table*))
+           (default-unary-prefix-printer (cadr term) (cadr x)))
+          ((setq x (assoc (car (cadr term)) *negative-unary-suffix-table*))
+           (default-unary-suffix-printer (cadr term) (cadr x)))
+          (t (default-unary-prefix-printer term *neg-str*)))))
+
+(declare-fn-printer not (function not-printer))
+
+;; REAL INITIALIZATION.  Used to reinitialize during clean-up-everything
+(setq *save-fn-alist* *fn-alist*)
+
+
+;                          USER MODIFIABLE TABLE SETUP
+
+; It is easy to augment, or even to modify, the syntax by calling one of the
+; make-... functions illustrated below.  The non-initial arguments to these
+; make-...  functions are strings to be printed by Latex to generate operators
+; and other noise words when printing a term whose function symbol is the
+; intial argument of the call to make-...
+
+; make-infix-op, make-unary-prefix-op, and make-unary-suffix-op take an
+; optional second argument, *neg-str*, which indicates how to print an the
+; negation of an application of the function symbol in question.
+
+; In TeX or Latex, one can do astonishingly clever things.  But the strings
+; that we have in mind should do nothing clever involving motion, they should
+; only result in characters being placed at the current location.  While being
+; printed, the strings will be passed no arguments or information about the
+; context in which printing is to take place. Typically, these strings should
+; be nothing more than instructions to print a single symbol. The strings are
+; processed in `math mode', and in fact, they are auomatically embedded in
+; $...$.
+
+; None of the operators below are built into this printer anywhere else except
+; by the code below.  The meaning of `not', defined above, is wired in because
+; it gives the meaning to the optional *neg-str* arguments.
+
+
+;                                     CONSTANT-OPS
+
+; Sometimes you want to print a function as a constant, particularly if it is one.
+; (make-constant-op op str) causes (op ..) to print as str. 
+
+;                                     INFIX-OPS
+
+; infix-ops (infix operators) should be function symbols of two or more
+; arguments for which it is desired that one symbol come out between every
+; adjacent pair of arguments.  E.g., invoking (make-infix-op plus "+") causes
+; the term (plus a b c d) to be printed as (a $+$ b $+$ c $+$ d).  Invoking
+; (make-infix-op equal "=" "\\not=") causes the term (equal x y) to be printed
+; as (x $=$ y) and it also causes the term (not (equal x y)) to be printed as
+; (x $\not= y).
+
+; Thus, for example, if one introduces a new function, say join, and wants to
+; print terms of the form (join x y) as (x \bigtriangledown y), cf. p. 44 of
+; the Latex manual, then one should invoke:
+
+;   (make-infix-op join "\\bigtriangledown")
+
+; from Lisp.  That is all that need be done to cause infix-file to subsequently
+; print `join' terms this way.
+
+; Note that throughout the following examples, we have used two backslashes to
+; get one because, in Common Lisp, backslash is a character for quoting other
+; characters.
+
+; Examples of make-infix-op are contained in latex-theory.lisp.  Look for INFIX OPERATORS.
+
+
+;             UNARY-PREFIX-OPS, UNARY-SUFFIX-OPS, and UNARY-ABS-OPS
+
+; Use make-unary-prefix-op and make-unary-suffix-op only for function symbols
+; of one argument.  The string str (or *neg-str*) will be printed before or
+; after the argument.
+
+; For more examples, see latex-theory.lisp.
+
+; unary-suffix-ops should be unary function symbols.
+
+; (make-unary-suffix-op foo x str) makes (foo x) print as (x $str$).
+
+; Examples of make-unary-suffix-op.
+
+; unary-prefix-ops should be unary function symbols. 
+
+; (make-unary-prefix-op foo str) makes (foo x) print as ($str$ x).
+
+; unary-abs-ops should be unary function symbols.
+
+; To create syntax like that for absolute value, use (make-unary-absolute-op
+; lhs-str rhs-str), where lhs-str and rhs-str are the strings to print on the
+; left and right of the argument.  (make-unary-abs-op foo str1 str2) makes (foo
+; x) print as (str1 x str2).  See the example for abs below.
+
+
+;                           SOME POSSIBLE EXTENSIONS
+
+
+;; (simple-extension)           ; see latex-theory.lisp
+;; (dmg-syntax)                 ; see latex-theory.lisp
+
+; Undoing.  To cause applications of a function symbol fn to be printed in the
+; default way, i.e., fn(x, y), invoke (clean-up 'fn).
+
+
+;; TESTING
+
+;; Lines in the test file are the following form:
+
+;;    filename 
+;; or (filename mode)
+;; or (filename mode comment)
+
+;; Comment defaults to T.
+
+(defvar *mode-list* '("latex" "scribe"))
+
+(defvar *test-file* "testfile")
+
+;; Better to use test-directory
+;; (defun test-infix ()
+;;   (let ((files (read-file-list *test-file*)))
+;;     (sloop for test in files
+;;              do (cond ((or (stringp test)
+;;                            (and (consp test) (null (cdr test))))
+;;                        ;; "file" or (file)
+;;                        (if (consp test) (setq test (car test)))
+;;                        (sloop for mode in *mode-list*
+;;                                 do (progn
+;; 				     (format *terminal-io*
+;; 					     "~%Translating ~a in ~a mode.~%" test mode)
+;; 				     (infix-file test :mode mode :comment t))))
+;;                       ((and (consp test) (eql (length test) 2))
+;;                        ;; (file mode)
+;;                        (format *terminal-io*
+;; 			       "~%Translating ~a in ~a mode.~%" (car test) (cadr test))
+;;                        (infix-file (car test) :mode (cadr test) :comment t))
+;;                       ((and (consp test) (eql (length test) 3))
+;;                        ;; (file mode comment)
+;;                        (format *terminal-io* 
+;;                                "~%Translating ~a in ~a mode, with comment = ~a.~%"
+;;                                (car test) (cadr test) (caddr test))
+;;                        (infix-file (car test) :mode (cadr test) :comment (caddr test)))
+;;                       (t (format *terminal-io* "~%BAD TEST FILE SPEC: ~ad.~%" test))))))
+
+;; (defun read-file-list (file)
+;;   (cond ((null (probe-file file))
+;;          (format t "~%Failed to find file: ~a~%" file))
+;;         (t (with-open-file
+;;             (*standard-input* file :direction :input)
+;;             (sloop for form = (readx *standard-input* nil a-very-rare-cons nil)
+;;                      until (eq form a-very-rare-cons)
+;;                      collect form)))))
+
+
+;; Testing functions
+
+;; MODIFY and USE:
+;; mks: script test.log
+;; mks: 
+;; >(load "infix")
+;; >(test-directory "scribe")
+;; >(bye)
+;; mks: foreach f (*.mss)
+;; ? scribe $f
+;; ? end
+;; mks: ^D
+;; mks: sed -e s/^V^M// test.log > test-scribe.log
+
+(defun test-directory (mode &optional directory (comment nil comment-p))
+  ;; ONLY EXPECTING mode = "latex" or "scribe"
+  (let ((type (if (string= mode "latex") "tex" "mss"))
+	(dir (or directory *infix-test-directory*))
+	;; Default testing excludes nqfmt2fmt translations
+	;; for latex, since it is so much more sensitive
+	;; to character weirdness.
+	(com (if (string= mode "latex") nil t)))
+    (if comment-p (setq com comment))
+    (setq dir (concatenate 'string dir "*.lisp"))
+    (mapc (function (lambda (f) 
+                      (format *terminal-io* "~%Infixing ~a.lisp." (pathname-name f))
+                      (if (probe-file (make-pathname :type type :defaults f))
+                          (format *terminal-io* "~%~a.~a already exists. Skipping.~%"
+				  (pathname-name f) type)
+                          (infix-file f :mode mode))))
+          (directory dir))))
+
+(format *terminal-io* "~%~%--- Do (help-infix-settings) for help. ---~%~%")
+
+
+#| Note on math printing from LSmith.
+
+Bill and I had troubles printing with infix because nesting math modes
+is not allowed in latex. Our latex output from infix is filled with 
+
+     {\ifmmode <form>\else$<form>$\fi}
+
+with the two <form>s identical and often containing more ifmmodes.
+
+I happened across a solution to this problem in the Latex manual.
+
+     \mbox{$<form>$}
+
+works whether of not we are currently in mathmode. In other words, it
+is possible to nest math modes in latex after all. This feature is
+documented in section 3.4.1, Defining Commands, in the Latex manual.
+
+|#
\ No newline at end of file
--- /dev/null
+++ acl2-6.0/interface/infix/makefile
@@ -0,0 +1,84 @@
+
+# ACL2 Version 1.9
+
+# Copyright (C) 1989-96 Computational Logic, Inc. (CLI).  All rights reserved.
+
+# Use of this software constitutes agreement with the terms of ACL2
+# license agreement, found in the file LICENSE.
+
+#  Example invocations (see README):
+
+#   make             ; Recompile what's needed. 
+#   make example     ; Create and print example forms in MODE.
+#   make events      ; Create and print example events in MODE.
+#   make clean       ; Cleanup everything but .o files and TAG table.
+#   make tags        ; Create TAG table.
+#   make full        ; Clean, compile, create TAGS, and print example in MODE.
+
+LISP =  acl2
+DIR =   /acl2/interface/infix
+SAVED = ${DIR}/Save
+# TEST =  ${DIR}/test
+TEST =  ${DIR}/books
+# MODE =  "scribe"
+MODE =  "latex"
+LPR = lpr
+DVI = dvips
+
+sources = infix.lisp scribe-init.lisp latex-init.lisp
+
+# 'make' without a target uses the first one, e.g.
+
+compile: ${sources}
+	rm -f workxxx
+	echo ':q' > workxxx
+	echo '(in-package "user")' >> workxxx
+	echo '(when (find-package "sloop") (use-package "sloop"))' >> workxxx
+	echo '(compile-file "infix.lisp")' >> workxxx
+	echo '(load "infix")' >> workxxx
+	echo '(compile-file "scribe-init.lisp")' >> workxxx
+	echo '(compile-file "latex-init.lisp")' >> workxxx
+	${LISP} < workxxx
+	rm -f workxxx
+
+full:   clean tags example events
+
+tags:   ${sources}
+	etags *.lisp
+
+example: 
+	rm -f workxxx 
+	echo ':q' > workxxx
+	echo '(in-package "user")' >> workxxx
+	echo '(when (find-package "sloop") (use-package "sloop"))' >> workxxx
+	echo '(load "infix")' >> workxxx
+	echo '(print-examples ${MODE})' >> workxxx
+	${LISP} < workxxx
+	if [ ${MODE} = "scribe" ] ; then \
+	  scribe infix-examples.mss ; scribe infix-examples.mss ; ${LPR} infix-examples.ps;\
+	else \
+	  rm -f infix-examples.aux ; latex infix-examples ; ${DVI} -o infix-examples.ps infix-examples ; \
+	fi
+
+events: #clean-doc
+	rm -f workxxx
+	echo ':q' > workxxx
+	echo '(in-package "user")' >> workxxx
+	echo '(when (find-package "sloop") (use-package "sloop"))' >> workxxx
+	echo '(load "infix")' >> workxxx
+	echo '(infix-file "sample.lisp" :mode "${MODE}")' >> workxxx
+	${LISP} < workxxx
+	if [ ${MODE} = "scribe" ] ; then \
+	  scribe sample.mss ; else \
+	  latex sample && latex sample && ${DVI} -o sample.ps sample ; \
+	fi
+
+clean-all:  clean
+	rm -f *.o TAGS
+
+clean: clean-doc
+	rm -f *~* *#* workxxx *.o *.tex *.nqtex TAGS *.dvi *.ps *.err *.aux *.log *.idx
+
+clean-doc:
+	rm -f ${DIR}/*.otl ${DIR}/*.err ${DIR}/*.ps ${DIR}/*.aux
+	rm -f ${DIR}/*.dvi ${DIR}/*.aux ${DIR}/*.log ${DIR}/*.idx ${DIR}/.log 
--- /dev/null
+++ acl2-6.0/interface/infix/latex-init.lisp
@@ -0,0 +1,739 @@
+; ACL2 Version 1.9
+
+; Copyright (C) 1989-96 Computational Logic, Inc. (CLI).  All rights reserved.
+
+; Use of this software constitutes agreement with the terms of ACL2
+; license agreement, found in the file LICENSE.
+
+;; Init file for infix.lisp in Latex mode.
+;; Feb 20 1992, by MKSmith
+;; This file depends on the LaTeX .sty file, "CLI.sty".
+;; CLI.sty should be stored in *infix-directory*.
+
+(in-package "user")
+
+(format *terminal-io* "Loading the ainfix latex-init file.")
+
+;; Mode should actually be set before this file is loaded.
+
+(infix-settings :mode                   "latex"
+		:extension              "tex"   
+		:op-location            'front  
+		:comment-format         'smith
+		:format-!-in-comments   nil      
+		:eliminate-top-parens   t       
+		:eliminate-inner-parens nil   
+		:no-index-calls         nil )
+
+(defparameter *rightmost-char-number* 100)
+(defparameter *default-chars-wide* 100)
+(defparameter *latex-indent-number-limit* 14)
+
+(defparameter nqread-normal-clause-enders
+  (append '(#\\ #\{) nqread-default-normal-clause-enders))
+
+
+;; THE LATEX PRELUDE.
+
+(defparameter *standard-prelude*
+  (format nil "\\documentstyle[makeidx,~aCLI]{article}~%~
+   \\makeindex~%~
+   %\\setlength{\\oddsidemargin}{.5in}~%~
+   %\\setlength{\\evensidemargin}{.5in}~%~
+   %\\setlength{\\textwidth}{5.8in}~%~
+   \\begin{document}~%~
+   %\\setlength{\\parindent}{0pt}~%~
+   %\\newcounter{bean}~%~
+   %\\begin{list}{\\arabic{bean}.}~
+   {\\usecounter{bean}~
+   \\setlength{\\leftmargin}{0pt}~
+   \\setlength{\\rightmargin}{0pt}~
+   \\setlength{\\listparindent}{20pt}~
+   \\setlength{\\parsep}{5pt}}~
+   ~%%\\item[]~%~%" *infix-directory*))
+
+(defparameter *standard-postlude*
+ "%\\end{list}
+\\printindex
+\\end{document}
+")
+
+(defparameter *example-prelude*
+  "\\documentstyle{article} \\begin{document} 
+
+Here is a summary of the conventional syntax (~a) in terms of the official syntax
+of the Nqthm logic.
+
+\\begin{enumerate}
+\\item Variables are printed in italics, unless specified otherwise in the table below.
+
+\\item Function application.  For any function symbol for which special
+syntax is not given below, an application of the symbol is printed with
+the usual notation; e.g., the term !v(fn x y z) is
+printed as !t(fn x y z).  Note that the function symbol is printed in
+Roman.  In the special case that !qc is a function symbol of no
+arguments, i.e., it is a constant, the term !v(c) is printed merely as
+!t(c), in small caps, with no trailing parentheses.  Because variables are printed in
+italics, there is no confusion between the printing of variables and
+constants.
+
+\\item Other constants.
+Quoted constants are printed in the ordinary syntax of the Nqthm logic,
+in a `typewriter font.'  For example,
+{\\tt '(a b c)} is still printed just that way.  \\verb+#b001+ is printed
+as !t#b001, \\verb+#o765+ is printed as !t#o765, and \\verb+#xa9+ is printed as
+!t#xa9, representing binary, octal and hexadecimal, respectively.")
+
+(defparameter *example-table-size*  40)
+
+(defparameter *begin-example-table* "~%~%\\begin{tabular}{|c|c|}\\hline~%~
+ Nqthm Syntax & Conventional Syntax \\\\ \\hline \\hline")
+
+(defparameter *end-example-table* "  \\hline \\end{tabular}
+")
+
+(defparameter *example-postlude* "\\end{document}")
+
+;; BASIC BRACKETS AND THEIR QUOTED VERSION.
+
+(defparameter *begin* "{")
+(defparameter *end*   "}")
+
+(defparameter *lbrace* "\{")
+(defparameter *rbrace* "\}")
+
+;; NEWLINE PARAMETERS
+
+(defparameter *newline-in-env* "\\\\")
+(defparameter *newline-in-text* "")
+
+(defparameter *force-newline-in-env* "\\\\")
+(defparameter *force-newline-in-text* "\\hfill \\break ")
+
+;; ENVIRONMENT BEGIN-END PAIRS
+
+(defparameter *begin-index* "\\index{")
+(defparameter *end-index* "}")
+
+(defparameter *begin-text-env* "")
+(defparameter *end-text-env*  "")
+
+(defparameter *begin-verbatim-env* "\\begin{verbatim}")
+(defparameter *end-verbatim-env* "\\end{verbatim}")
+
+(defparameter *begin-format-env* "\\begin{CLIverbatim}\\begin{rm}")
+(defparameter *end-format-env* "\\end{rm}\\end{CLIverbatim}")
+
+;; Depends on CLI.sty
+(defparameter *begin-emphasis-env*  "\\begin{CLIverbatim}\\begin{it}")
+(defparameter *end-emphasis-env*    "\\end{it}\\end{CLIverbatim}")
+
+(defparameter *begin-section-env*  "\\section{")
+(defparameter *end-section-env*    "}")
+
+(defparameter *begin-subsection-env*  "\\subsection{")
+(defparameter *end-subsection-env*    "}")
+
+(defparameter *begin-tt-env* "{\\tt{")
+(defparameter *end-tt-env*   "}}")
+
+(defparameter *begin-string-env*  "{\\tt{")
+(defparameter *end-string-env*    "}}")
+
+(defparameter *begin-bold-env* "{\\bf{")
+(defparameter *end-bold-env*   "}}")
+
+(defparameter *begin-italic-env* "{\\it{")
+(defparameter *end-italic-env*   "\\/}}")
+
+(defparameter *begin-sc-env* "{\\sc{")
+(defparameter *end-sc-env*   "}}")
+
+;; This won't work.
+
+(defparameter *begin-comment-env*  "%")
+(defparameter *end-comment-env*    "
+")
+
+(defparameter *begin-enumerate-env* "\\begin{enumerate}")
+(defparameter *end-enumerate-env* "\\end{enumerate}")
+(defparameter *begin-item* "\\item ")
+(defparameter *end-item* "")
+
+(defparameter *mv-bracket-left* "$\\langle$")
+(defparameter *mv-bracket-right* "$\\rangle$")
+
+(defparameter *forall* "$\\forall\\;$")
+(defparameter *exists* "$\\exists\\;$")
+
+
+;; TABBING AND INDENTING ENVIRONMENT AND TAB OPERATIONS
+
+;; I don't know how to do this in Latex.
+(defparameter *begin-group-tabbing-env* "\\begin{tabbing}
+")
+(defparameter *begin-tabbing-env* "\\begin{tabbing}
+")
+(defparameter *end-tabbing-env* "\\end{tabbing}
+")
+(defparameter *new-tab-row* " \\\\")
+
+;; Just in case some other mode defined it otherwise.
+(defun new-tab-row (&optional followed-by-infix-print-term)
+  (declare (ignore followed-by-infix-print-term))
+  (pprinc *new-tab-row*))
+
+(defparameter *tab* "\\>")
+(defparameter *flush* "\\`")
+
+(defparameter *column-separator* "&")
+
+(defparameter *tab-list* nil)
+
+(defparameter *set-margin* "\\=\\+")
+(defparameter *pop-margin* "\\-")	
+(defparameter *set-tab*    "\\=")
+
+(defparameter *default-op-tab-space* "$\\quad$ ")
+(defparameter *indent-string* "$\\quad$ ")
+(defparameter *default-indent* 2)
+
+(defun get-op-width-string (op)
+  (declare (ignore op))
+  nil)
+
+(defparameter *noindent* "\\noindent ")
+
+;; Not properly defined yet.
+(defun begin-normal-text () (line-return))
+(defun end-normal-text () (line-return))
+
+(defvar *tab-stack* nil)
+
+(defun begin-tabbing ()
+
+; Tabbing environments cannot be nested in Latex.
+
+  (if (null *tab-stack*)
+      (princ *begin-tabbing-env*))
+  (setq *tab-stack* (cons *tab-list* *tab-stack*))
+  (setq *tab-list* nil)
+
+  (if (> *left-margin* 0) 
+      (progn (sloop for i from 1 to *left-margin* do (pprinc "M"))
+	     (pprinc "\\=\\+\\kill")
+	     (pwrite-char #\Newline)))
+  (setq *infix-loc* *left-margin*))
+
+(defun begin-group-tabbing ()
+
+  (if (null *tab-stack*)
+      (princ *begin-group-tabbing-env*))
+  (setq *tab-stack* (cons *tab-list* *tab-stack*))
+  (setq *tab-list* nil)
+
+  (if (> *left-margin* 0) 
+      (progn (sloop for i from 1 to *left-margin* do (pprinc "M"))
+	     (pprinc "\\=\\+\\kill")
+	     (pwrite-char #\Newline)))
+  (setq *infix-loc* *left-margin*))
+
+(defun end-tabbing ()
+  (cond ((null *tab-stack*))
+	((null (cdr *tab-stack*))   
+	 (setq *tab-list* (car *tab-stack*))
+	 (setq *tab-stack* nil)
+	 (princ *end-tabbing-env*))
+	(t (setq *tab-list* (car *tab-stack*))
+	   (setq *tab-stack* (cdr *tab-stack*)))))
+
+;; (defun begin-tabbing ()
+;; 
+;; ; Tabbing environments cannot be nested in Latex.
+;; 
+;;   (setq *tab-list* nil)
+;;   (princ *begin-tabbing-env*)
+;;   (if (> *left-margin* 0) 
+;;       (progn (sloop for i from 1 to *left-margin* do (pprinc "M"))
+;; 	     (pprinc "\\=\\+\\kill")
+;; 	     (pwrite-char #\Newline)))
+;;   (setq *infix-loc* *left-margin*))
+;; 
+;; (defun begin-group-tabbing ()
+;;   (setq *tab-list* nil)
+;;   (princ *begin-group-tabbing-env*)
+;;   (if (> *left-margin* 0) 
+;;       (progn (sloop for i from 1 to *left-margin* do (pprinc "M"))
+;; 	     (pprinc "\\=\\+\\kill")
+;; 	     (pwrite-char #\Newline)))
+;;   (setq *infix-loc* *left-margin*))
+;; 
+;; (defun end-tabbing ()
+;;   (princ *end-tabbing-env*))
+
+(defun increase-margin ()
+  (pprin1i *default-op-tab-space*)
+  (set-margin))
+
+(defun set-margin ()
+
+; Generate instructions to set the current indentation.
+; In latex we use tabs, which cause *tabto* to tab to this column in the future.  
+; `Punt' if we hit the limit, by throwing all the way out.
+
+  (cond (*do-not-use-tabs* nil)
+        (t (cond ((= *tabs-in* *latex-indent-number-limit*)
+                  (throw 'taboverflow t)))
+           (setq *tabs-in* (1+ *tabs-in*))
+	   (adjust-margin-to-last-tab-first *tab-list*)
+	   (pprinc *set-margin*)
+	   (push (cons 'lm *infix-loc*) *tab-list*))))
+
+(defun adjust-margin-to-last-tab-first (tl)
+  (cond ((null tl))
+	((eq (caar tl) 'tab)
+	 (pprinc "\\+")
+	 (adjust-margin-to-last-tab-first (cdr tl)))
+	(t nil)))
+
+(defun get-margin ()
+  (get-margin2 *tab-list*))
+
+(defun get-margin2 (tl)
+  (let ((setting (car tl)))
+    (cond ((null setting) *left-margin*)
+	  ((eq (car setting) 'lm) (cdr setting))
+	  (t (get-margin2 (cdr tl))))))
+
+(defun begin-flushright ()
+  (pprinc *flush*))
+
+(defun end-flushright () nil)
+
+(defun flushright (form)
+  (begin-flushright)
+  (pprinc form)
+  (end-flushright))
+
+(defun do-tab ()
+  (cond (*do-not-use-tabs* (pprinc " "))
+	((and *tab-list* (eq (caar *tab-list*) 'tab))
+	 (pprinc *tab*))
+	(t (pprinc " "))))
+
+(defun set-tab (&optional op)
+
+; Generate instructions to set a tab at the current location.
+; `Punt' if we hit the limit, by throwing all the way out.
+
+  (cond (*do-not-use-tabs* nil)
+        (t (cond ((= *tabs-in* *latex-indent-number-limit*)
+                  (throw 'taboverflow t)))
+           (setq *tabs-in* (1+ *tabs-in*))
+	   (cond ((and op (get-op-width-string op))
+		  (pprinc (get-op-width-string op)))
+		 (t (pprinc *default-op-tab-space*)))
+           (push (cons 'tab *infix-loc*) *tab-list*)
+           (pprinc *set-tab*))))
+
+(defun pop-tab ()
+  ;; We don't really remove tabs from the formatted env.
+  ;; Just track them in Lisp.
+  ;; Generate command to `tab to one tab less in'.
+  ;; Do not pop tabs beyond left margin.
+  (cond (*do-not-use-tabs* nil)
+	((and *tab-list* (eq (caar *tab-list*) 'tab))
+	 (setq *tabs-in* (1- *tabs-in*))
+	 ;; We don't tell TeX to remove the tab.  This works because
+	 ;; before we try to use tabi again, we will reset its value.
+	 (pop *tab-list*))
+	(t nil)))
+
+(defun pop-margin ()
+  ;; Generate command to `return to one margin less in'.
+  ;; If there are tabs after the margin, they are popped as well.
+  ;; NOTE:  The way this must work in Latex is that if there
+  ;; are tabs they are just ignored.  If there is an LM
+  ;; we pop it as well as any \+ that were done to move over tabs
+  ;; to it.
+  (cond (*do-not-use-tabs* nil)
+	((null *tab-list*) nil)
+	((and (eq (caar *tab-list*) 'tab)
+	      (eq (caadr *tab-list*) 'lm))
+	 (pop-tab)
+	 (pop *tab-list*)
+	 (setq *tabs-in* (1- *tabs-in*))
+	 (pprinc *pop-margin*)
+	 (adjust-margin-to-first-tab-last *tab-list*))
+	((and *tab-list* (eq (caar *tab-list*) 'lm))
+	 (setq *tabs-in* (1- *tabs-in*))
+	 (pop *tab-list*)
+	 (pprinc *pop-margin*)
+	 (adjust-margin-to-first-tab-last *tab-list*))
+	(t nil)))
+
+(defun adjust-margin-to-first-tab-last (tl)
+  (cond ((null tl))
+	((eq (caar tl) 'tab)
+	 (pprinc "\\-")
+	 (adjust-margin-to-first-tab-last (cdr tl)))
+	(t nil)))
+
+;; (defun to-current-margin ()
+;;   ;; Generates command for return to current indentation setting,
+;;   ;; unless we are already there.
+;;   (cond (*do-not-use-tabs* (pprinci " "))
+;; 	((eql *infix-loc* (get-margin)))
+;; 	(t (pprinc *new-tab-row*)
+;; 	   (setq *infix-loc* (get-margin)))))
+
+;; (defun newline-to-current-margin ()
+;;   ;; Generates command for return to current indentation setting.'  
+;;   (cond (*do-not-use-tabs* (pprinci " "))
+;; 	(t (pprinc *new-tab-row*)
+;; 	   (setq *infix-loc* (get-margin)))))
+
+;; (defun force-newline ()
+;;   ;; Forces a newline in running text OR in a tabbing env.
+;;   (if (null *tab-list*)
+;;       (progn (pprinci "\\hfill \\break ")
+;; 	     (pwrite-char #\Newline)
+;; 	     (cond (*do-not-use-tabs*)
+;; 		   (t (setq *infix-loc* (get-margin)))))
+;;       (progn (cond (*do-not-use-tabs* (pprinci " "))
+;; 		   (t (pprinc *new-tab-row*)
+;; 		      (setq *infix-loc* (get-margin)))))))
+
+;; FONTS
+
+(defparameter *function-font* "\\rm")
+
+(defun roman-font (term)
+  (pprinc "{")
+  (pprinc *function-font*)
+  (pprinc "{")
+  (print-atom term)
+  (pprinc "}}"))
+
+
+;; MATH ENV AND OPERATORS
+
+(defparameter *neg-str* (format nil "$~a$"  "\\neg"))
+
+(defparameter *math-format* "$~a$")
+(defparameter *math-begin* "$")
+(defparameter *math-end* "$")
+
+(defparameter *math-thick-space* "\\;")
+(defparameter *math-thin-space* "\\,")
+
+(defparameter *subscript* "_")
+
+(defparameter *begin-subscript* "\\(_{")
+(defparameter *end-subscript* "}\\)")
+
+;; MISC
+
+(defparameter *newpage* "\\newpage")
+
+(defparameter *comma-atsign* ",@")
+(defparameter *caret* "\\char'136")	;; It is a tad subtle getting a caret printed.
+(defparameter *tilde* "\\char'176")	;; It is a tad subtle getting a tilde printed.
+
+(defparameter *dotted-pair-separator* " .\\ ")           ; I don't understand the \\
+(defparameter *dotted-pair-separator-newline* ".\\ ")    ; ditto
+
+(defparameter *no-tab-event-trailer* "~%~%\\addvspace{10pt}")
+(defparameter *print-default-event-header* "~%\\noindent{\\sc Event}:   ")
+(defparameter *print-default-lisp-header* "~%\\noindent{\\sc Lisp}:   ")
+
+(defparameter *print-default-command-header*  "~%\\noindent~%")
+(defparameter *no-tab-command-trailer* "~%~%\\addvspace{10pt}")
+
+
+
+
+;; OTHER FUNCTIONS
+
+(defparameter doc-special-chars (coerce "#$%&~_^\\{}" 'list))
+(defparameter doc-other-chars   (coerce "<>|" 'list))
+(defparameter doc-index-specials (coerce "@|!\"" 'list))
+
+;; We didn't compile the following because the compiler declaration
+;; in Sinfix, through a bug in AKCL, caused this routine to produce
+;; spurious results.
+
+;; The patch to akcl that is loaded in sinfix should fix this problem.
+;; Other lisps shouldn't need it.
+;; These use to be of the form (eval-when (load) (eval '<defn>))
+
+(defun handle-special-chars (char)
+  ;; USED BY PRINT-ATOM.  CHAR is local to print-atom.
+  (cond ((eql char #\^)
+	 (pprinc "\\verb|^|"))
+	((eql char #\~)
+	 (pprinc *tilde*)
+	 (incf *infix-loc* 1))
+	((member char doc-special-chars)
+	 (pwrite-char #\\)
+	 (pwrite-char (cond ((eq *print-case* :downcase)
+			     (char-downcase char))
+			    (t char))))
+	((member char doc-other-chars)
+	 (pwrite-char #\$)
+	 (pwrite-char (cond ((eq *print-case* :downcase)
+			     (char-downcase char))
+			    (t char)))
+	 (pwrite-char #\$))
+	(t (pwrite-char (cond ((eq *print-case* :downcase)
+			       (char-downcase char))
+			      (t char))))))
+
+(defun handle-special-chars-in-string (char)
+  ;; USED BY PRINT-ATOM.  CHAR is local to print-atom.
+  (cond ((eql char #\~)
+	 (pprinc *tilde*)
+	 (incf *infix-loc* 1))
+	((member char doc-special-chars)
+	 (incf *infix-loc* 1)
+	 (pwrite-char #\\)
+	 (pwrite-char char))
+	((member char doc-other-chars)
+	 (incf *infix-loc* 2)
+	 (pwrite-char #\$)
+	 (pwrite-char char)
+	 (pwrite-char #\$))
+	(t (pwrite-char char))))
+
+
+;; PRINTING INDEX ENTRIES
+
+; Who could ever have guessed that it would take this much code to print out a
+; simple \index{foo} command for an arbitrary Nqthm function symbol foo.  There
+; are so many special cases one can hardly believe one's eyes.
+
+(defparameter index-subitem-length 30)
+
+(defun index (x &optional subkind)
+
+#|
+Yuk city on quotations of weird characters.
+
+See the latex guide to indexes,
+tex3.0/TeX3.0/LaTeX/LaTeXmakeindex/doc/makeindex.tex.  The characters vertical
+bar, @, and ! are used within index strings, and need to be quoted with a
+single double quote mark.
+
+Also, it looks like makeindex chokes on index entries of more than 64
+characters, in the sense that after 64, things suddenly become subitems, which
+is a good way to get screwed if there are weird characters in the first 64 that
+need quoting or balancing.
+
+|#
+
+  (pprinc *begin-index*)
+  (let ((str (if (stringp x) x (symbol-name x)))
+        (num-chars 0)
+        (inserted-excl nil))
+
+    (if subkind
+	(cond ((stringp subkind) (setq str (concatenate 'string str ", " subkind)))
+	      ((symbolp subkind) (setq str (concatenate 'string str ", " (string subkind))))
+	      (t nil)))
+
+    (sloop with brace-count = 0
+             for i below (length str)
+             for char = (char (the string str) (the fixnum i))
+             until (> num-chars *index-entry-max*)
+             do
+             (progn
+               (cond ((and (> num-chars index-subitem-length)
+                           (not inserted-excl)
+                           (= brace-count 0))
+
+; There is some sort of a bug in the Latex indexing machinery whereby if an
+; entry has more than 64 characters, a `subitem' is automatically started.  But
+; this may happen in a bad place, in terms of character quotation, so we force
+; a subitem earlier, at our convenience.
+
+                      (pwrite-char #\!)
+                      (setq inserted-excl t)))
+
+; It is a tad subtle getting a caret or tilde printed.
+
+	       (cond ((eql char #\^)
+                      (pprinc *caret*)
+                      (incf num-chars 8))
+
+		     ((eql char #\~)
+                      (pprinc *tilde*)
+                      (incf num-chars 8))
+
+; If braces are not balanced, the index machinery will barf, so we keep track
+; and try to help out later, if we can.
+
+                     ((eql char #\{)
+                      (incf brace-count 1)
+                      (pwrite-char #\\)	;!!! This won't work in Scribe.
+                      (pwrite-char char)
+                      (incf num-chars 2))
+                     ((eql char #\})
+                      (decf brace-count 1)
+                      (pwrite-char #\\)
+                      (pwrite-char char)
+                      (incf num-chars 2))
+
+; There are the special characters like @ which have a special meaning just in
+; Latex indexing, and they have to be quoted their own special way.
+
+                     ((member char doc-index-specials)
+                      (pwrite-char #\")
+                      (pwrite-char char)
+                      (incf num-chars 2))
+
+; And of course, one has to watch our for such standard special TeX characters
+; as $.
+
+                     ((member char doc-special-chars)
+                      (pwrite-char #\\)
+                      (pwrite-char char)
+                      (incf num-chars 2))
+
+; If one tries to set an ordinary < or >, it won't work, and just quoting with
+; backslash doesn't work either, so we sneak into math mode.
+
+                     ((member char doc-other-chars)
+                      (pwrite-char #\$)
+                      (pwrite-char char)
+                      (pwrite-char #\$)
+                      (incf num-chars 3))
+                     (t (pwrite-char (cond ((eq *print-case* :downcase)
+                                            (char-downcase char))
+                                           (t char)))
+                        (incf num-chars 1)))
+               (cond ((< brace-count 0)
+                      (pformat *terminal-io*
+                               "~% Error: The index entry for ~a will ~
+                                fail because of the imbalance of set ~
+                                braces.~%"
+                               x))))
+             finally
+             (progn
+                (cond ((> num-chars *index-entry-max*)
+                       (pformat *terminal-io*
+                                "~% Warning: Index entry for ~a truncated to ~a characters. ~%"
+                                 x num-chars)
+                       (pprinc "...")))
+                (cond ((not (equal brace-count 0))
+                       (cond ((> brace-count 0)
+                              (sloop for i from 1 to brace-count do
+                                       (pprinc "\\}"))))
+                       (pformat *terminal-io*
+                                "~%Warning:  Balancing set braces on ~
+                                 ~a so Latex indexing will work.~%"
+                                x))))))
+  (pprinc *end*))
+
+(defun skip-index-entries ()
+  ;; We are looking at a backslash.  If this begins an index entry, in Tex 
+  ;; mode we need to skip to the end of the entry, because we may have added !'s.  
+  ;; In Scribe mode this function returns NIL.
+  (let ((pos (file-position *standard-input*))
+	(index '(#\i #\n #\d #\e #\x #\{))
+	success
+	c)
+      (sloop for x on index
+	       while (and x (char= (setq c (read-char *standard-input* nil a-very-rare-cons)) (car x)))
+	       finally (cond ((null x)
+			      (pprinc "\\index{")
+			      (skip-to-brace)
+			      (setq success t))))
+      (cond ((not success)
+	     ;; Back to read the char immediately following the #\.
+	     (file-position *standard-input* pos)
+	     nil)
+	    (t t))))
+
+(defun adjust-tabbing-env ()
+  ;; We are looking at a backslash. In Tex mode we want to replace 
+  ;;   ....  \\
+  ;;   \end{tabbing}
+  ;; with
+  ;;   ....  
+  ;;   \end{tabbing}
+  ;; Worse and worse.  There is more than one such pattern.
+  (let ((pos (file-position *standard-input*))
+	(patterns '((#\\ #\newline #\\ #\- #\\ #\e #\n #\d #\{ #\t #\a #\b #\b #\i #\n #\g #\})
+		   (#\\ #\newline #\\ #\e #\n #\d #\{ #\t #\a #\b #\b #\i #\n #\g #\})))
+	success
+	c)
+    (sloop for pattern in patterns
+	   while (not success)
+	   do (progn
+		(sloop for x on pattern
+		       while (char= (setq c (read-char *standard-input* nil a-very-rare-cons)) (car x))
+		       finally (cond ((null x)
+				      (line-return)
+				      (pprinc "\\end{tabbing}")
+				      (setq success t))))
+		(if (not success)
+		    ;; Back to read the char immediately following the #\.
+		    (file-position *standard-input* pos))))
+    success))
+
+(defun skip-to-brace ()
+  ;; Skip to next non-quoted #\}.
+  ;; We assume one exists.
+  (sloop for c = (read-char *standard-input* nil a-very-rare-cons)
+	   until (char= c #\})
+	   do    (cond ((char= c #\\)
+			;; Handle imbedded, quoted right braces.
+			(pwrite-char c)
+			(pwrite-char (read-char *standard-input* nil a-very-rare-cons)))
+		       (t (pwrite-char c))))
+  (pwrite-char #\}))
+
+(defparameter acl2-char-subst-table
+ '((#\~ #\\ #\c #\h #\a #\r #\' #\1 #\7 #\6 #\ )
+   (#\^ #\\ #\c #\h #\a #\r #\' #\1 #\3 #\6 #\ )
+   (#\# #\\ #\#)
+   (#\& #\\ #\&)
+   (#\$ #\\ #\$)
+   (#\% #\\ #\%)
+   (#\_ #\\ #\_)
+   (#\\ #\\ #\\)
+   (#\{ #\\ #\{)
+   (#\} #\\ #\})
+   (#\< #\$ #\< #\$)
+   (#\> #\$ #\> #\$)
+   (#\| #\$ #\| #\$)))
+
+
+(defparameter acl2-markup-table
+  '(("-"   . "---")
+    ("B"   . "{\\bf ~sa}")
+    ("BF"  . "~%\\begin{CLIverbatim}\\begin{rm}")  
+    ("BID" . "")		     ;begin implementation dependent
+    ("BQ"  . "~%\\begin{quotation}")
+    ("BV"  . "~%\\begin{verbatim}")
+    ("C"   . "{\\tt ~sa}")	     ;originally @code, but we don't want `' in info file
+    ("EF"  . "\\end{rm}\\end{CLIverbatim}~%")
+    ("EID" . "")		     ;end implementation dependent
+    ("EM"  . "{\\it ~sa}")           ;emphasis
+    ("EQ"  . "~%\\end{quotation}~%") ;TexInfo needs leading line break to 
+				     ;avoid problems with @refill
+    ("EV"  . "\\end{verbatim}~%")
+    ("I"   . "{\\it ~sa}")
+    ("ID"  . "~sa")		     ;implementation dependent
+    ("IL"  . "~sa")
+    ("ILC" . "{\\tt ~sa}")	     ;originally @code, but problem with info file
+    ("L"   . "See ~sA")   
+    ("NL"  . "\\hfill \\break ")
+    ("PAR" . "")		     ;paragraph mark, of no significance for latex
+    ("PL"  . "see ~sA")		     ;used for parenthetical crossrefs
+    ("SC"  . "{\\sc ~sa}")	     ;small caps
+    ("ST"  . "{\\bf ~sa}")	     ;strong emphasis
+    ("T"   . "{\\tt ~sa}")
+    ("TERMINAL" . "")		     ; terminal only, ignore
+    ))
+
--- /dev/null
+++ acl2-6.0/interface/infix/README
@@ -0,0 +1,168 @@
+Copyright (C) 1994,1995,1996 Computational Logic, Inc. (CLI).
+All Rights Reserved.
+
+Infix printing for 
+
+ ACL2 Version 1.9
+
+Use of this software constitutes agreement with the terms of ACL2
+license agreement, found in the file LICENSE in the top level ACL2 
+distribution directory.
+
+Comments, bugs, suggestions to:
+
+  Michael K. Smith
+  Computational Logic Inc.
+  1717 W 6th, Suite 290
+  Austin, TX 78703-4776
+
+  Fax  : (512) 322-0656
+  Email: mksmith@cli.com
+
+  Date : Mar 27 59
+
+--------------------------------------------------------------------------
+PROBLEMS
+
+The only known problem (as of the above date) is with `!' formatting
+directives in comments.  If you depend on this capability (by using
+INFIX-FILE with `:comment t') then you need to make sure that all uses
+of ! in your file are acceptable.  In general, ! as punctuation will
+be fine, but things like `{!foo}*' will cause problems, i.e. you may
+experience unpredictable formatting results, or worse, a break into
+lisp.  In this case, you will need to either correct the problem or run 
+INFIX-FILE with `!' processing suppressed (which is the default).
+You can guarantee it by:
+
+ (infix-file "foo" :comment nil) 
+
+There is also a problem with deeply indented forms in LaTeX.  The
+depth of indentation permitted depends on your LaTeX installation.  On
+ours, it is 13, which is wired into the file latex-init.lisp, in the
+variable *latex-indent-number-limit*.  If this limit is exceeded the
+form is printed as lisp, rather than in infix, and we issue a message:
+
+ Warning: Tab limit reached in event local
+ Hand massaging required.
+
+--------------------------------------------------------------------------
+INSTALLATION
+
+For decent speed the system should be compiled.
+
+The best way to build the system is as follows:
+
+1. First build ACL2
+
+2. Connect to the infix installation directory.
+
+3. Set the following macros properly in the file "makefile":
+
+ LISP = acl2
+ DIR  = /slocal/src/acl2/v1-8/interface/infix
+ LPR  = lpr
+ DVI  = dvips
+
+DIR should point to the installation directory.  When I use {$DIR} in
+the rest of this file, I mean for it to be replaced by whatever you
+have set DIR to.  LPR should be the command on your system to print
+a .ps file.  DVI should print LaTeX output, without requiring an extension.
+
+4. UNFORTUNATE NOTE:  Near the top of the file "infix.lisp" is the form
+
+ (require "sloop" "/slocal/src/acl2/v1-8/interface/infix/sloop")
+
+You need to change that directory name to reflect the actual location
+of the infix sources.  E.g.
+
+ (require "sloop" "{$DIR}/sloop")
+
+5. Do:
+
+ make compile
+ 
+It is important to do this in the directory in which infix resides.
+For one thing, that's where the makefile is and for another it causes
+the variable, *infix-directory*, to get set properly.
+
+It is possible to build the system in a bare lisp by setting
+`LISP=lucid' or some other lisp.  But I do not recommend this as the
+system has not been extensively tested in that mode.
+
+6. To perform a simple test of the system and get some idea of what
+the results look like do:
+
+ make example
+
+Depending on what MODE is set to in your makefile, this will either produce
+infix-examples.ps (from Scribe) or infix-examples.dvi file (from LaTeX) and
+send them to a poscript printer.
+
+7. You might want to make the script doinfix executable (by `chmod +x doinfix').
+You can then infix your files at the shell prompt by 
+
+ doinfix file.lisp scribe &
+
+In order for this to work you will first need to modify the following
+line in doinfix:
+
+ set DIR = /slocal/src/acl2/v1-8/interface/infix
+
+to point to ${DIR}. 
+--------------------------------------------------------------------------
+USE
+
+The simplest way to run the program is to use step 7, above.  Failing
+that, the next simplest approach is as follows:
+
+Connect to the directory containing the ACL2 .lisp files that you want
+to convert to infix.  
+
+If `LISP' was set to ACL2 in the compilation phase then start up ACL2
+and do:
+  
+ :q                              ;; to exit the ACL2 loop
+ (in-package "user")
+ (load "{$DIR}/infix")
+
+Where `{$DIR}' is whatever directory path is needed to get to
+"infix.o".
+
+If 'LISP' was set to something else, start that lisp and do:
+
+ (load "{$DIR}/infix")
+
+In either case, the basic call is then 
+
+  (infix-file <file> :mode <mode>) 
+
+where <file> is the name of a .lisp file and, in the
+simplest case, <mode> is one of "scribe" or "latex".  For example:
+
+  (infix-file "clock" :mode "scribe") 
+  (infix-file "clock.lisp" :mode "scribe") works too.
+
+See the documentation in infix.lisp for information on user
+parameterization and extension of modes.  In particular, see the
+section `SETTINGS THAT MAY BE MODIFIED IN MODE-THEORY.LISP'.
+
+Just as a note, if you have an events file, say clock.lisp, and
+create a corresponding theory file, clock-theory.lisp, then you can
+use the even simpler invocation:
+
+  (infix-file "clock") 
+
+The simplest such a clock-theory file might just consist of:
+
+  (in-package "user")
+  (load-base "latex-theory")
+
+By default, infix expects the scribe-theory and latex-theory files to
+be in *infix-directory*.  And they in turn expect their corresponding
+-init files to be there also. 
+
+Other -theory files may reside in *infix-directory* or in the `current
+directory' (defined to be the directory returned by (probe-file "./")
+at execution time).  The current directory is checked first.
+
+
--- /dev/null
+++ acl2-6.0/interface/emacs/top-start-shell-acl2.el
@@ -0,0 +1,8 @@
+(defvar *acl2-interface-dir*
+  "/projects/acl2/v2-x/interface/emacs/")
+
+(setq *acl2-user-map-interface*
+  '((global keys)))
+
+(let ((load-path (cons *acl2-interface-dir* load-path)))
+  (load "load-shell-acl2"))
--- /dev/null
+++ acl2-6.0/interface/emacs/README-mouse.ps
@@ -0,0 +1,1421 @@
+%!PS-Adobe-2.0
+%%Title: README.mss
+%%DocumentFonts: (atend)
+%%Creator: J Strother Moore and Scribe 7(1750)
+%%CreationDate: 18 September 1995 15:44
+%%Pages: (atend)
+%%EndComments
+% PostScript Prelude for Scribe.
+/BS {/SV save def
+        /PH exch 100 div def
+        /PW exch 100 div def
+         0.0 PH translate
+         .01 -.01 scale} bind def
+/ES {SV restore showpage} bind def
+/SC {setrgbcolor} bind def
+/FMTX matrix def
+/RDF {WFT SLT 0.0 eq 
+  {SSZ 0.0 0.0 SSZ neg 0.0 0.0 FMTX astore}
+  {SSZ 0.0 SLT neg sin SLT cos div SSZ mul SSZ neg 0.0 0.0 FMTX astore}
+  ifelse makefont setfont} bind def
+/SLT 0.0 def
+/SI { /SLT exch cvr def RDF} bind def
+/WFT /Courier findfont def
+/SF { /WFT exch findfont def RDF} bind def
+/SSZ 1000.0 def
+/SS { /SSZ exch 100.0 mul def RDF} bind def
+/AF { /WFT exch findfont def /SSZ exch 100.0 mul def RDF} bind def
+/MT /moveto load def
+/PF{transform .25 sub round .25 add exch
+  .25 sub round .25 add exch itransform} bind def
+/RPF{currentpoint exch 4 1 roll
+  add 3 1 roll add exch PF} bind def
+/XM {currentpoint exch pop moveto} bind def
+/UL {gsave newpath moveto dup 2.0 div 0.0 exch RPF moveto
+   setlinewidth 0.0 rlineto stroke grestore} bind def
+/LH {gsave newpath PF moveto setlinewidth
+   0.0 rlineto
+   gsave stroke grestore} bind def
+/LV {gsave newpath PF moveto setlinewidth
+   0.0 exch rlineto
+   gsave stroke grestore} bind def
+/BX {gsave newpath PF moveto setlinewidth
+   exch
+   dup 0.0 RPF lineto
+   exch 0.0 exch neg RPF lineto
+   neg 0.0 RPF lineto
+   closepath
+   gsave stroke grestore} bind def
+/BX1 {grestore} bind def
+/BX2 {setlinewidth 1 setgray stroke grestore} bind def
+/PB {/PV save def newpath translate
+    100.0 -100.0 scale pop /showpage {} def} bind def
+/PE {PV restore} bind def
+/GB {/PV save def newpath translate rotate
+    div dup scale 100.0 -100.0 scale /showpage {} def} bind def
+/GE {PV restore} bind def
+/FB {dict dup /FontMapDict exch def begin} bind def
+/FM {cvn exch cvn exch def} bind def
+/FE {end /original-findfont /findfont load def  /findfont
+   {dup FontMapDict exch known{FontMapDict exch get} if
+   original-findfont} def} bind def
+/BC {gsave moveto dup 0 exch rlineto exch 0 rlineto neg 0 exch rlineto closepath clip} bind def
+/EC /grestore load def
+/SH /show load def
+/MX {exch show 0.0 rmoveto} bind def
+/W {0 32 4 -1 roll widthshow} bind def
+/WX {0 32 5 -1 roll widthshow 0.0 rmoveto} bind def
+/RC {100.0 -100.0 scale
+PW 0.0 translate
+-90.0 rotate
+.01 -.01 scale} bind def
+/URC {100.0 -100.0 scale
+90.0 rotate
+PW neg 0.0 translate
+.01 -.01 scale} bind def
+/RCC {100.0 -100.0 scale
+0.0 PH neg translate 90.0 rotate
+.01 -.01 scale} bind def
+/URCC {100.0 -100.0 scale
+-90.0 rotate 0.0 PH translate
+.01 -.01 scale} bind def
+/CL {gsave newpath moveto setrgbcolor
+       exch
+       dup 0.0 rlineto
+       exch 0.0 exch neg rlineto
+       neg 0.0 rlineto
+     fill grestore} bind def
+%%EndProlog
+%%Page: 1 1
+
+93600 79200 BS
+0 SI
+13 /Times-Roman AF
+19716 9892 MT
+(The ACL2 Prooftree and Mouse Interface)SH
+10 SS 
+24655 13132 MT
+(M. Kaufmann & M. K. Smith)SH
+12 /Times-Bold AF
+7200 17536 MT
+(1. Introduction)300 W
+10 /Times-Roman AF
+7200 19478 MT
+(NOTE: This)
+425 W( interface should be considered preliminary, although it has been used successfully at Computational)87 W
+7200 20583 MT
+(Logic, Inc.  It is not part of the ACL2 software in the strictest sense \050which is co-authored by Matt)
+29 W( Kaufmann and J)30 W
+7200 21688 MT
+(Moore\051, but we feel that it will be useful to ACL2 users.)SH
+7200 23898 MT
+(This note describes how to get the ACL2/Emacs prooftree and mouse support.  You just need to add)
+177 W( a single)176 W
+7200 25003 MT
+(autoload form to your .emacs file.  And then issue the correspoding M-x command.)SH
+7200 27213 MT
+(The prooftree support has been tested in the following Emacs:)SH
+7450 28823 MT
+(Emacs 18)SH
+7450 29928 MT
+(Emacs 19)
+SH( -)
+1750 W( with comint and WFS's shell, sshell.el.)SH
+7450 31033 MT
+(Lemacs 19)SH
+7200 33243 MT
+(The menu and mouse support currently works with Emacs 19.)SH
+/Times-Bold SF
+7200 35453 MT
+(If you don't want)
+245 W( to deal with any of this:)246 W
+/Times-Roman SF
+28098 XM
+(You probably want to put the following form in your acl2-)246 W
+7200 36558 MT
+(customization.lisp file.)SH
+/Courier-Bold SF
+7800 38820 MT
+(:STOP-PROOF-TREE)SH
+/Times-Roman SF
+7200 41768 MT
+(This will turn off the proof tree printing from ACL2.  For documentation in ACL2 do)SH
+/Courier-Bold SF
+7800 43573 MT
+(:doc proof-tree)SH
+/Times-Roman SF
+7200 45390 MT
+(To turn proof trees back on use `:START-PROOF-TREE'.)SH
+7200 46495 MT
+(NOTE: If you do `:STOP-PROOF-TREE' in ACL2, then M-x start-proof-tree will not)
+2 W( accomplish anything useful in)1 W
+7200 47600 MT
+(Emacs.)SH
+12 /Times-Bold AF
+7200 51284 MT
+(2. LOADING)
+300 W( EMACS INTERFACE CODE)SH
+11 SS 
+7200 54181 MT
+(2.1 Simplest)
+275 W( .emacs Additions)SH
+10 /Times-Roman AF
+7200 56035 MT
+(If you want the full interface, put the following in your .emacs file after)
+23 W( replacing /slocal/src/acl2/v1-8/ with the full)24 W
+7200 57140 MT
+(pathname of your acl2-sources/ directory.)SH
+/Courier-Bold SF
+7800 59402 MT
+(\050setq *acl2-interface-dir*)SH
+9000 60533 MT
+("/slocal/src/acl2/v1-8/interface/emacs/"\051)SH
+7800 62795 MT
+(\050autoload 'run-acl2 ;;)SH
+/Times-Italic SF
+(emacs 19.27 only at this time)SH
+/Courier-Bold SF
+9000 63926 MT
+(\050concat *acl2-interface-dir* "top-start-inferior-acl2"\051)SH
+9000 65057 MT
+("Begin ACL2 in an inferior ACL2 mode buffer.")SH
+9000 66188 MT
+(t\051)SH
+/Times-Roman SF
+7200 69136 MT
+(Then, to get things started in Emacs do `M-x run-acl2'.  Use `M-x acl2-mode' to get `<acl2-file>.lisp' into)
+30 W( the right)29 W
+7200 70241 MT
+(mode. The)
+278 W( commands in the various modes are listed in a later)
+14 W( section.  But you can see most of them by observing)15 W
+7200 71346 MT
+(the new)
+62 W( pull-down menus and pop-up menu in inferior ACL2 mode and ACL2 mode.  The pop-up menu is tied to)61 W
+ES
+%%Page: 2 2
+
+93600 79200 BS
+0 SI
+10 /Times-Roman AF
+7200 4286 MT
+(The ACL2 Prooftree and Mouse Interface)SH
+53500 XM
+(2)SH
+7200 5391 MT
+(Internal Note)SH
+7200 9686 MT
+(mouse-3.)SH
+7200 11896 MT
+(If you just want proof trees, use the following after replacing /slocal/src/acl2/v1-8/ with the full)
+80 W( pathname of your)81 W
+7200 13001 MT
+(acl2-sources/ directory.)SH
+/Courier-Bold SF
+7800 15263 MT
+(\050setq *acl2-interface-dir*)SH
+9000 16394 MT
+("/slocal/src/acl2/v1-8/interface/emacs/"\051)SH
+7200 18656 MT
+(\050autoload 'start-proof-tree)SH
+8400 19787 MT
+(\050concat *acl2-interface-dir* "top-start-shell-acl2"\051)SH
+8400 20918 MT
+("Enable proof tree logging in a prooftree buffer.")SH
+8400 22049 MT
+(t\051)SH
+11 /Times-Bold AF
+7200 26077 MT
+(2.2 More)
+275 W( Control from .emacs: Setting preferences)SH
+10 /Times-Roman AF
+7200 27931 MT
+(The alist, *acl2-user-map-interface*, determines what menus you)
+86 W( get.  If a feature is included after a mode name,)85 W
+7200 29036 MT
+(then you get it.)SH
+/Courier-Bold SF
+7200 31298 MT
+(\050defvar *acl2-user-map-interface*)SH
+8400 32429 MT
+('\050\050inferior-acl2-mode menu-bar popup-menu keys\051)SH
+9600 33560 MT
+(\050acl2-mode menu-bar)
+5400 W( popup-menu keys\051)SH
+9600 34691 MT
+(\050prooftree-mode menu-bar)
+2400 W( popup-menu keys\051\051\051)SH
+/Times-Roman SF
+7200 38032 MT
+(If you set the following to T, you will switch to the inferior ACL2 buffer)
+46 W( when you send forms, regions, or buffers)47 W
+7200 39137 MT
+(to it.)SH
+/Courier-Bold SF
+7800 41399 MT
+(\050setq *acl2-eval-and-go* nil\051)SH
+/Times-Roman SF
+7200 44347 MT
+(If you set the following)
+78 W( to NIL you will be queried for their values when you start up a prooftree buffer \050via M-x)77 W
+7200 45452 MT
+(start-proof-tree\051. These)
+250 W( are the defaults you get based on the autoload above.)SH
+/Courier-Bold SF
+7800 47714 MT
+(\050setq *acl2-proof-tree-height* 17\051)SH
+7800 48845 MT
+(\050setq *checkpoint-recenter-line* 3\051)SH
+12 /Times-Bold AF
+7200 53660 MT
+(3. Commands)300 W
+10 /Times-Roman AF
+7200 55602 MT
+(Commands are enabled based on the value of the alist, *acl2-user-map-interface*, as described above.)
+101 W( There)
+454 W( are)102 W
+7200 56707 MT
+(some conventions that you need to know regarding arguments to mouse commands.)SH
+7200 58917 MT
+(If a menu bar entry is of the form)SH
+7950 60527 MT
+(Print event ...)SH
+7200 62137 MT
+(the "..." indicates that you will be prompted in the minibuffer for an argument.)SH
+7200 64347 MT
+(If a menu bar entry is of the form)SH
+7950 65957 MT
+(Mode >)SH
+7200 67567 MT
+(the ">" indicates a suborninate menu that will pop up if you release on this menu item.)SH
+7200 69777 MT
+(Pop-up menu items indicate whether)
+59 W( they take an argument based on a preceding ".".  The argument is determined)58 W
+7200 70882 MT
+(by what you clicked on to bring up the)
+105 W( menu.  Arguments derived from things that appear in the chronology are)106 W
+7200 71987 MT
+(somewhat robust.  So that if you had a list of events on the screen like:)SH
+ES
+%%Page: 3 3
+
+93600 79200 BS
+0 SI
+10 /Times-Roman AF
+7200 4286 MT
+(The ACL2 Prooftree and Mouse Interface)SH
+53500 XM
+(3)SH
+7200 5391 MT
+(Internal Note)SH
+/Courier-Bold SF
+12600 9674 MT
+(13 \050DEFMACRO)
+600 W( TEXT \050X\051 ...\051)SH
+7800 10805 MT
+(L 14)
+3600 W( \050DEFUN)
+600 W( MSG-P \050X\051 ...\051)SH
+7800 11936 MT
+(L 15)
+3600 W( \050DEFUN)
+600 W( MAKE-PACKET \050X Y Z\051 ...\051)SH
+7800 13067 MT
+(L 16)
+3600 W( \050DEFUN)
+600 W( HISTORY-P \050L\051 ...\051)SH
+12600 14198 MT
+(17 \050DEFMACRO)
+600 W( INFROM \050X\051 ...\051)SH
+/Times-Roman SF
+7200 16015 MT
+(to see event 14 you could click right anywhere on that line and select either ". Print Event" or ". Print Command".)SH
+11 /Times-Bold AF
+7200 18912 MT
+(3.1 Prooftree)
+275 W( Related)SH
+10 /Times-Roman AF
+9000 20766 MT
+(M-x start-proof-tree)SH
+9000 21871 MT
+(M-x stop-proof-tree)SH
+11 /Times-Bold AF
+7200 24768 MT
+(3.2 Prooftree)
+275 W( Mode)SH
+7200 27665 MT
+(3.2-A POPUP)
+275 W( MENU)SH
+10 /Times-Roman AF
+9000 29519 MT
+(Abort)SH
+23400 XM
+(Abort *inferior-acl2*.)SH
+9000 30624 MT
+(Goto subgoal)SH
+23400 XM
+(Go to clicked on subgoal in *inferior-acl2*.)SH
+9000 31729 MT
+(Resume proof tree)SH
+23400 XM
+(Resume printing proof tree.)SH
+9000 32834 MT
+(Suspend proof tree)SH
+23400 XM
+(Suspend printing proof tree.)SH
+9000 33939 MT
+(Checkpoint/Suspend)SH
+23400 XM
+(Suspend prooftree and go to clicked on checkpoint.)SH
+9000 35044 MT
+(Checkpoint)SH
+23400 XM
+(Go to clicked on checkpoint.)SH
+9000 36149 MT
+(Help)SH
+11 /Times-Bold AF
+7200 39046 MT
+(3.2-B MENU)
+275 W( BAR)SH
+10 /Times-Roman AF
+9000 40900 MT
+(Prooftree)SH
+11050 42510 MT
+(Checkpoint)SH
+23400 XM
+(Go to next checkpoint)SH
+11050 43615 MT
+(Goto subgoal)SH
+23400 XM
+(That cursor is on.)SH
+11050 44720 MT
+(Checkpoint / Suspend)SH
+23400 XM
+(Go to next checkpoint and suspend proof tree.)SH
+11050 45825 MT
+(Resume proof tree)SH
+11050 46930 MT
+(Suspend proof tree)SH
+11050 48035 MT
+(Abort)SH
+23400 XM
+(Abort prooftree. \050ACL2 will continue to send prooftrees, it just)SH
+23400 49140 MT
+(won't go the the prooftree buffer.\051)SH
+11050 50245 MT
+(Help)SH
+11 /Times-Bold AF
+7200 53142 MT
+(3.2-C KEYS)275 W
+10 /Times-Roman AF
+9000 54996 MT
+(C-z z)SH
+23400 XM
+(Previous C-z key binding)SH
+9000 56101 MT
+(C-z c)SH
+23400 XM
+(Go to checkpoint)SH
+9000 57206 MT
+(C-z s)SH
+23400 XM
+(Suspend proof tree)SH
+9000 58311 MT
+(C-z r)SH
+23400 XM
+(Resume proof tree)SH
+9000 59416 MT
+(C-z a)SH
+23400 XM
+(Mfm abort secondary buffer)SH
+9000 60521 MT
+(C-z g)SH
+23400 XM
+(Goto subgoal)SH
+9000 61626 MT
+(C-z h)SH
+23400 XM
+(help)SH
+9000 62731 MT
+(C-z ?)SH
+23400 XM
+(help)SH
+ES
+%%Page: 4 4
+
+93600 79200 BS
+0 SI
+10 /Times-Roman AF
+7200 4286 MT
+(The ACL2 Prooftree and Mouse Interface)SH
+53500 XM
+(4)SH
+7200 5391 MT
+(Internal Note)SH
+11 /Times-Bold AF
+7200 9737 MT
+(3.3 ACL2)
+275 W( Mode)SH
+10 /Times-Roman AF
+7200 11591 MT
+(ACL2 Mode is like Lisp)
+147 W( mode except that the functions that send sexprs to the inferior Lisp process expect an)146 W
+7200 12696 MT
+(inferior ACL2 process in the *inferior-acl2* buffer.)SH
+11 /Times-Bold AF
+7200 15593 MT
+(3.3-A POPUP)
+275 W( MENU)SH
+10 /Times-Roman AF
+9000 17447 MT
+(Send to ACL2)SH
+23400 XM
+(Send top level form clicked on to ACL2.)SH
+9000 18552 MT
+(Add hint)SH
+23400 XM
+(Add the hint form to the clicked on defun.)SH
+10800 20162 MT
+(Do not induct.)SH
+10800 21267 MT
+(Do not generalize.)SH
+10800 22372 MT
+(Do not fertilize.)SH
+10800 23477 MT
+(Expand)SH
+23400 XM
+(expand form. Requests you mouse it.)SH
+10800 24582 MT
+(Hands off.)SH
+10800 25687 MT
+(Disable)SH
+23400 XM
+(Disable symbol. Requests you mouse it.)SH
+10800 26792 MT
+(Enable)SH
+23400 XM
+(Enable symbol. Requests you mouse it.)SH
+10800 27897 MT
+(Induct)SH
+23400 XM
+(Induct based on form. Requests you mouse it.)SH
+10800 29002 MT
+(Cases)SH
+23400 XM
+(Perform case split on form.Requests you mouse it.)SH
+9000 30612 MT
+(Go to inferior ACL2)SH
+9000 31717 MT
+(Verify)SH
+23400 XM
+(Take clicked on form into interactive prover.)SH
+11 /Times-Bold AF
+7200 34614 MT
+(3.3-B KEYS)275 W
+10 /Times-Roman AF
+9000 36468 MT
+(C-x C-e)SH
+23400 XM
+(eval last sexp)SH
+9000 37573 MT
+(C-c C-r)SH
+23400 XM
+(eval region)SH
+9000 38678 MT
+(C-M-x)SH
+23400 XM
+(eval defun)SH
+9000 39783 MT
+(C-c C-e)SH
+23400 XM
+(eval defun)SH
+9000 40888 MT
+(C-c C-z)SH
+23400 XM
+(switch to ACL2)SH
+9000 41993 MT
+(C-c C-l)SH
+23400 XM
+(load file)SH
+9000 43098 MT
+(C-c C-a)SH
+23400 XM
+(show arglist)SH
+9000 44203 MT
+(C-c C-d)SH
+23400 XM
+(describe symbol)SH
+9000 45308 MT
+(C-c C-f)SH
+23400 XM
+(show function documentation)SH
+9000 46413 MT
+(C-c C-v)SH
+23400 XM
+(show variable documentation)SH
+9000 47518 MT
+(C-ce)SH
+23400 XM
+(eval defun and go to ACL2)SH
+9000 48623 MT
+(C-cr)SH
+23400 XM
+(eval region and go to ACL2)SH
+11 /Times-Bold AF
+7200 51520 MT
+(3.4 Inferior)
+275 W( ACL2 Mode)SH
+7200 54417 MT
+(3.4-A MENU)
+275 W( BAR)SH
+10 /Times-Roman AF
+9000 56271 MT
+(Events)SH
+11050 57881 MT
+(Recent events)SH
+23400 XM
+(\050pbt '\050:here -10\051\051)SH
+11050 58986 MT
+(Print back through ...)SH
+23400 XM
+(\050pbt <event>\051)SH
+11050 60091 MT
+(Undo)SH
+23400 XM
+(\050ubt ':here\051)SH
+11050 61196 MT
+(Oops)SH
+23400 XM
+(\050oops\051)SH
+11050 62301 MT
+(Undo through ...)SH
+23400 XM
+(\050ubt '<event>\051)SH
+11050 63406 MT
+(Undo through ...)SH
+23400 XM
+(\050ubt! '<cd>\051)SH
+11050 65616 MT
+(Load file ...)SH
+23400 XM
+(\050cl2-load-file\051)SH
+11050 67826 MT
+(Disable ...)SH
+23400 XM
+(\050in-theory \050disable <symbol>\051\051)SH
+11050 68931 MT
+(Enable ...)SH
+23400 XM
+(\050in-theory \050enable <symbol>\051\051)SH
+11050 71141 MT
+(Verify guards ...)SH
+23400 XM
+(\050verify-guards '<symbol>\051)SH
+ES
+%%Page: 5 5
+
+93600 79200 BS
+0 SI
+10 /Times-Roman AF
+7200 4286 MT
+(The ACL2 Prooftree and Mouse Interface)SH
+53500 XM
+(5)SH
+7200 5391 MT
+(Internal Note)SH
+11050 9686 MT
+(Verify termination ...)SH
+23400 XM
+(\050verify-guards '<symbol>\051)SH
+11050 11896 MT
+(Certify-book ...)SH
+23400 XM
+(\050certify-book <filename>\051)SH
+11050 13001 MT
+(Include-book ...)SH
+23400 XM
+(\050include-book <filename> \051)SH
+10800 15211 MT
+(Compound commands)SH
+12850 16821 MT
+(Expand compound command ...)SH
+27000 XM
+(\050puff '<cd>\051)SH
+12850 17926 MT
+(Expand compound command! ...)SH
+27000 XM
+(\050puff* '<cd>\051)SH
+10800 20136 MT
+(Table)SH
+12850 21746 MT
+(Print value ...)SH
+23400 XM
+(\050table symbol\051)SH
+12850 22851 MT
+(Clear ...)SH
+23400 XM
+(\050table <symbol> nil nil :clear)SH
+12850 23956 MT
+(Print guard ...)SH
+23400 XM
+(\050table <symbol> nil nil :guard\051)SH
+9000 26166 MT
+(Print)SH
+11050 28376 MT
+(Event ...)SH
+23400 XM
+(\050pe 'event\051)SH
+11050 29481 MT
+(Event! ...)SH
+23400 XM
+(\050pe! 'event\051)SH
+11050 30586 MT
+(Back through ...)SH
+23400 XM
+(\050pbt 'event\051)SH
+11050 32796 MT
+(Command ...)SH
+23400 XM
+(\050pc '<cd>\051)SH
+11050 33901 MT
+(Command block ...)SH
+23400 XM
+(\050pcb '<cd>\051)SH
+11050 35006 MT
+(Full Command block ...)SH
+23400 XM
+(\050pcb! '<cd>\051)SH
+11050 37216 MT
+(Signature ...)SH
+23400 XM
+(\050args 'event\051)SH
+11050 38321 MT
+(Formula ...)SH
+23400 XM
+(\050pf 'event\051)SH
+11050 39426 MT
+(Properties ...)SH
+23400 XM
+(\050props 'event\051)SH
+11050 41636 MT
+(Print connected book directory)SH
+25200 XM
+(\050cbd\051)SH
+11050 43846 MT
+(Rules whose top function symbol is ...)SH
+27000 XM
+(\050pl 'event\051)SH
+11050 44951 MT
+(Rules stored by event ...)SH
+23400 XM
+(\050pr 'event\051)SH
+11050 46056 MT
+(Rules stored by command ...)SH
+23400 XM
+(\050pr! '<cd>\051)SH
+11050 48266 MT
+(Monitored-runes)SH
+23400 XM
+(\050monitored-runes\051)SH
+9000 50476 MT
+(Control)SH
+11050 52686 MT
+(Load ...)SH
+23400 XM
+(\050ld filename\051)SH
+11050 53791 MT
+(Accumulated Persistence)SH
+13100 55401 MT
+(Activate)SH
+23400 XM
+(\050accumulated-persistence t\051)SH
+13100 56506 MT
+(Deactivate)SH
+23400 XM
+(\050accumulated-persistence nil\051)SH
+13100 57611 MT
+(Display statistics ordered by)SH
+15150 59221 MT
+(frames)SH
+23400 XM
+(\050show-accumulated-persistence :frames\051)SH
+15150 60326 MT
+(times tried)SH
+23400 XM
+(\050show-accumulated-persistence :tries\051)SH
+15150 61431 MT
+(ratio)SH
+23400 XM
+(\050show-accumulated-persistence :ratio\051)SH
+12600 63041 MT
+(Break rewrite)SH
+14650 64651 MT
+(Start general rule monitoring)SH
+27000 XM
+(\050brr t\051)SH
+14650 65756 MT
+(Stop general rule monitoring)SH
+27000 XM
+(\050brr nil\051)SH
+14650 66861 MT
+(Print monitored runes)SH
+25200 XM
+(\050monitored-runes\051)SH
+14650 67966 MT
+(Monitor rune: ...)SH
+23400 XM
+(\050monitor '\050:definition <event>\051 't\051)SH
+14650 69071 MT
+(Unmonitor rune: ...)SH
+23400 XM
+(\050unmonitor '\050:definition <event>\051\051)SH
+12600 71281 MT
+(Commands)SH
+ES
+%%Page: 6 6
+
+93600 79200 BS
+0 SI
+10 /Times-Roman AF
+7200 4286 MT
+(The ACL2 Prooftree and Mouse Interface)SH
+53500 XM
+(6)SH
+7200 5391 MT
+(Internal Note)SH
+14650 9686 MT
+(Abort to ACL2 top-level)SH
+25200 XM
+(#.)SH
+14650 10791 MT
+(Term being rewritten)SH
+23400 XM
+(:target)SH
+14650 11896 MT
+(Substitution making :lhs equal :target)SH
+30600 XM
+(:unify-subst)SH
+14650 13001 MT
+(Hypotheses)SH
+23400 XM
+(:hyps)SH
+14650 14106 MT
+(Ith hypothesis ...)SH
+23400 XM
+(:hyp <integer>)SH
+14650 15211 MT
+(Left-hand side of conclusion)SH
+27000 XM
+(:lhs)SH
+14650 16316 MT
+(Right-hand side of conclusion)SH
+27000 XM
+(:rhs)SH
+14650 17421 MT
+(Type assumptions governing :target)SH
+30600 XM
+(:type-alist)SH
+14650 18526 MT
+(Ttree before :eval)SH
+23400 XM
+(:initial-ttree)SH
+14650 19631 MT
+(Negations of backchaining hyps pursued)SH
+32400 XM
+(:ancestors)SH
+14650 21841 MT
+(Rewrite's path from top clause to :target)SH
+32400 XM
+(:path)SH
+14650 22946 MT
+(Top-most frame in :path)SH
+25200 XM
+(:top)SH
+14650 24051 MT
+(Ith frame in :path ...)SH
+23400 XM
+(:frame <integer>)SH
+12600 26261 MT
+(AFTER :EVAL)SH
+14650 27871 MT
+(Did application succeed?)SH
+25200 XM
+(:wonp)SH
+14650 28976 MT
+(Rewritten :rhs)SH
+23400 XM
+(:rewritten-rhs)SH
+14650 30081 MT
+(Ttree)SH
+23400 XM
+(:final-ttree)SH
+14650 31186 MT
+(Reason rule failed)SH
+23400 XM
+(:failure-reason)SH
+12600 33396 MT
+(CONTROL)SH
+14650 35006 MT
+(Exit break)SH
+23400 XM
+(:ok)SH
+14650 36111 MT
+(Exit break, printing result)SH
+25200 XM
+(:go)SH
+14650 37216 MT
+(Try rule and re-enter break afterwards)SH
+30600 XM
+(:eval)SH
+12600 39426 MT
+(WITH NO RECURSIVE BREAKS)SH
+14650 41036 MT
+(:ok!)SH
+23400 XM
+(\050:ok!\051)SH
+14650 42141 MT
+(:go!)SH
+23400 XM
+(\050:go!\051)SH
+14650 43246 MT
+(:eval!)SH
+23400 XM
+(\050:eval!\051)SH
+12600 45456 MT
+(WITH RUNES MONITORED DURING RECURSION)SH
+14650 47066 MT
+(:ok ...)250 W
+23400 XM
+(\050:ok$ sexpr\051)SH
+14650 48171 MT
+(:go ...)SH
+23400 XM
+(\050:go$ sexpr\051)250 W
+14650 49276 MT
+(:eval ...)SH
+23400 XM
+(\050:eval$ sexpr\051)SH
+12850 50886 MT
+(Help)SH
+23400 XM
+(\050:help\051)SH
+11050 52496 MT
+(Enter ACL2 Loop)SH
+23400 XM
+(\050lp\051)SH
+11050 53601 MT
+(Quit to Common Lisp)SH
+23400 XM
+(:Q)SH
+11050 54706 MT
+(ABORT)SH
+23400 XM
+(\050:good-bye\051)SH
+9000 56916 MT
+(Settings)SH
+10800 59126 MT
+(Mode)SH
+12850 60736 MT
+(Logic)SH
+23650 XM
+(\050logic\051)SH
+12850 61841 MT
+(Program)SH
+23650 XM
+(\050program\051)SH
+12850 62946 MT
+(Guard checking on)SH
+23400 XM
+(\050set-guard-checking t\051)SH
+12850 64051 MT
+(Guard checking off)SH
+23400 XM
+(\050set-guard-checking nil\051)SH
+10800 66261 MT
+(Forcing)SH
+12850 67871 MT
+(On)SH
+23400 XM
+(\050enable-forcing\051)SH
+12850 68976 MT
+(Off)SH
+23400 XM
+(\050disable-forcing\051)SH
+10800 71186 MT
+(Compile functions)SH
+ES
+%%Page: 7 7
+
+93600 79200 BS
+0 SI
+10 /Times-Roman AF
+7200 4286 MT
+(The ACL2 Prooftree and Mouse Interface)SH
+53500 XM
+(7)SH
+7200 5391 MT
+(Internal Note)SH
+12850 9686 MT
+(On)SH
+23400 XM
+(\050set-compile-fns t\051)SH
+12850 10791 MT
+(Off)SH
+23400 XM
+(\050set-compile-fns nil\051)SH
+10800 13001 MT
+(Proof tree)SH
+12850 14611 MT
+(Start prooftree)SH
+23400 XM
+(\050start-proof-tree\051pre \050start-proof-tree nil\051\051)SH
+12850 15716 MT
+(Stop prooftree)SH
+23400 XM
+(\050stop-proof-tree\051post \050stop-proof-tree\051\051)SH
+12850 16821 MT
+(Checkpoint forced goals on)SH
+25200 XM
+(\050checkpoint-forced-goals\051)SH
+10800 19031 MT
+(Inhibit Display of)SH
+12850 20641 MT
+(Error messages)SH
+23400 XM
+(\050assign inhibit-output-lst '\050error\051\051)SH
+12850 21746 MT
+(Warnings)SH
+23400 XM
+(\050assign inhibit-output-lst '\050warning\051\051)SH
+12850 22851 MT
+(Observations)SH
+23400 XM
+(\050assign inhibit-output-lst '\050observation\051\051)SH
+12850 23956 MT
+(Proof commentary)SH
+23400 XM
+(\050assign inhibit-output-lst '\050prove\051\051)SH
+12850 25061 MT
+(Proof tree)SH
+23400 XM
+(\050assign inhibit-output-lst '\050prove\051\051)SH
+12850 26166 MT
+(Non-proof commentary)SH
+23400 XM
+(\050assign inhibit-output-lst '\050event\051\051)SH
+12850 27271 MT
+(Summary)SH
+23400 XM
+(\050assign inhibit-output-lst '\050summary\051\051)SH
+10800 29481 MT
+(Unused Variables)SH
+12850 31091 MT
+(Ignore)SH
+23400 XM
+(\050set-ignore-ok t\051)SH
+12850 32196 MT
+(Fail)SH
+23400 XM
+(\050set-ignore-ok nil\051)SH
+12850 33301 MT
+(Warn)SH
+23400 XM
+(\050set-ignore-ok :warn\051)SH
+10800 35511 MT
+(Irrelevant formulas)SH
+12850 37121 MT
+(Ok)SH
+23400 XM
+(\050set-irrelevant-formals-ok t\051)SH
+12850 38226 MT
+(Fail)SH
+23400 XM
+(\050set-irrelevant-formals-ok nil\051)SH
+12850 39331 MT
+(Warn)SH
+23400 XM
+(\050set-irrelevant-formals-ok :warn\051)SH
+10800 41541 MT
+(Load)SH
+12600 43151 MT
+(Error action)SH
+14650 44761 MT
+(Continue)SH
+23400 XM
+(\050set-ld-error-actions :continue\051)SH
+14650 45866 MT
+(Return)SH
+23400 XM
+(\050set-ld-error-actions :return\051)SH
+14650 46971 MT
+(Error)SH
+23400 XM
+(\050set-ld-error-actions :error\051)SH
+12600 49181 MT
+(Error triples)SH
+14650 50791 MT
+(On)SH
+23400 XM
+(\050set-ld-error-triples t\051)SH
+14650 51896 MT
+(Off)SH
+23400 XM
+(\050set-ld-error-triples nil\051)SH
+12600 54106 MT
+(Post eval print)SH
+14650 55716 MT
+(On)SH
+23400 XM
+(\050set-ld-post-eval-print t\051)SH
+14650 56821 MT
+(Off)SH
+23400 XM
+(\050set-ld-post-eval-print nil\051)SH
+14650 57926 MT
+(Command conventions)SH
+25200 XM
+(\050set-ld-post-eval-print :command-conventions\051)SH
+12600 60136 MT
+(Pre eval filter)SH
+14650 61746 MT
+(All)SH
+23400 XM
+(\050set-ld-pre-eval-filter :all\051)SH
+14650 62851 MT
+(Query)SH
+23400 XM
+(\050set-ld-pre-eval-filter :query\051)SH
+12600 65061 MT
+(Prompt)SH
+14650 66671 MT
+(On)SH
+23400 XM
+(\050set-ld-prompt t\051)SH
+14650 67776 MT
+(Off)SH
+23400 XM
+(\050set-ld-prompt nil\051)SH
+12600 69986 MT
+(Skip proofs)SH
+14650 71596 MT
+(On)SH
+23400 XM
+(\050set-ld-skip-proofs t\051)SH
+ES
+%%Page: 8 8
+
+93600 79200 BS
+0 SI
+10 /Times-Roman AF
+7200 4286 MT
+(The ACL2 Prooftree and Mouse Interface)SH
+53500 XM
+(8)SH
+7200 5391 MT
+(Internal Note)SH
+14650 9686 MT
+(Off)SH
+23400 XM
+(\050set-ld-skip-proofs nil\051)SH
+12600 11896 MT
+(Verbose: on)SH
+14650 13506 MT
+(On)SH
+23400 XM
+(\050set-ld-verbose t\051)SH
+14650 14611 MT
+(Off)SH
+23400 XM
+(\050set-ld-verbose nil\051)SH
+12850 16821 MT
+(Redefinition permitted)SH
+23400 XM
+(\050redef\051)SH
+12850 17926 MT
+(Reset specials)SH
+23400 XM
+(\050reset-ld-specials t\051)SH
+12600 19031 MT
+(HACKERS. DANGER!)SH
+14650 20641 MT
+(RED redefinition!)SH
+23400 XM
+(\050redef!\051)SH
+10800 23956 MT
+(Books)SH
+12850 25566 MT
+(Print connected book directory)SH
+27000 XM
+(\050cbd\051)SH
+12850 26671 MT
+(Set connected book directory ...)SH
+27000 XM
+(\050set-cbd filename\051)SH
+12850 27776 MT
+(Certify-book ...)SH
+23400 XM
+(\050certify-book filename\051)SH
+12850 28881 MT
+(Include-book ...)SH
+23400 XM
+(\050include-book filename\051)SH
+10800 31091 MT
+(ACL2 Help)SH
+12850 32701 MT
+(Documentation)SH
+23400 XM
+(\050doc '<symbol>\051)SH
+12850 33806 MT
+(Arguments)SH
+23400 XM
+(\050args '<symbol>\051)SH
+12850 34911 MT
+(More)SH
+23400 XM
+(\050more\051)SH
+12850 36016 MT
+(Apropos ...)SH
+23400 XM
+(\050docs '<symbol>\051)SH
+12850 37121 MT
+(Info)SH
+23400 XM
+(\050cl2-info\051)SH
+12850 38226 MT
+(Tutorial)SH
+23400 XM
+(\050acl2-info-tutorial\051)SH
+12850 39331 MT
+(Release Notes)SH
+23400 XM
+(\050cl2-info-release-notes\051)SH
+11 /Times-Bold AF
+7200 43333 MT
+(3.4-B INFERIOR)
+275 W( ACL2 POPUP MENU)SH
+10 /Times-Roman AF
+9250 45187 MT
+(Recent events)SH
+23400 XM
+(\050pbt '\050:here -10\051\051)SH
+9250 46292 MT
+(Print Event)SH
+23400 XM
+(\050pe '<symbol>\051)SH
+9250 47397 MT
+(Print back to)SH
+23400 XM
+(\050pbt '<cd>\051)SH
+9250 48502 MT
+(Disable)SH
+23400 XM
+(\050in-theory \050disable <symbol>\051\051)SH
+9250 49607 MT
+(Enable)SH
+23400 XM
+(\050in-theory \050enable <symbol>\051\051)SH
+9250 50712 MT
+(Undo)SH
+23400 XM
+(\050ubt ':here\051)SH
+9250 51817 MT
+(Undo thru)SH
+23400 XM
+(\050ubt '<cd>\051)SH
+9250 52922 MT
+(Documentation)SH
+23400 XM
+(\050doc '<symbol>\051)SH
+9250 54027 MT
+(Arguments, etc)SH
+23400 XM
+(\050args '<symbol>\051)SH
+9250 55132 MT
+(Verify)SH
+23400 XM
+(Take clicked on form into interactive prover.)SH
+11 /Times-Bold AF
+7200 58029 MT
+(3.4-C KEYS)275 W
+10 /Times-Roman AF
+9000 59883 MT
+(C-x C-e)SH
+23400 XM
+(Eval last sexp)SH
+9000 60988 MT
+(C-c C-l)SH
+23400 XM
+(Load file)SH
+9000 62093 MT
+(C-c C-a)SH
+23400 XM
+(Show arglist)SH
+9000 63198 MT
+(C-c C-d)SH
+23400 XM
+(Describe symbol)SH
+9000 64303 MT
+(C-c C-f)SH
+23400 XM
+(Show function documentation)SH
+9000 65408 MT
+(C-c C-v)SH
+23400 XM
+(Show variable documentation)SH
+9000 66513 MT
+(C-cl)SH
+23400 XM
+(Load file)SH
+9000 67618 MT
+(C-ck)SH
+23400 XM
+(Compile file)SH
+9000 68723 MT
+(C-ca)SH
+23400 XM
+(Show arglist)SH
+9000 69828 MT
+(C-cd)SH
+23400 XM
+(Describe symbol)SH
+9000 70933 MT
+(C-cf)SH
+23400 XM
+(Show function documentation)SH
+ES
+%%Page: 9 9
+
+93600 79200 BS
+0 SI
+10 /Times-Roman AF
+7200 4286 MT
+(The ACL2 Prooftree and Mouse Interface)SH
+53500 XM
+(9)SH
+7200 5391 MT
+(Internal Note)SH
+9000 9686 MT
+(C-cv)SH
+23400 XM
+(Show variable documentation)SH
+ES
+%%Page: i 10
+
+93600 79200 BS
+0 SI
+10 /Times-Roman AF
+30461 75600 MT
+(i)SH
+13 /Times-Bold AF
+18956 9871 MT
+(The ACL2 Prooftree and Mouse Interface)SH
+25977 14548 MT
+(Table of Contents)SH
+11 /Times-Roman AF
+9400 18903 MT
+(1. Introduction)
+SH( .)
+62 W( . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53450 XM
+(1)SH
+9400 20099 MT
+(2. LOADING EMACS INTERFACE CODE)
+SH( .)
+33 W( . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53450 XM
+(1)SH
+10 SS 
+10200 21204 MT
+(2.1. Simplest .emacs Additions)
+SH( .)
+55 W( . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53500 XM
+(1)SH
+10200 22309 MT
+(2.2. More Control from .emacs: Setting preferences)
+SH( .)
+365 W( . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53500 XM
+(2)SH
+11 SS 
+9400 23505 MT
+(3. Commands)
+SH( .)
+488 W( . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53450 XM
+(2)SH
+10 SS 
+10200 24610 MT
+(3.1. Prooftree Related)
+SH( .)
+224 W( . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53500 XM
+(3)SH
+10200 25715 MT
+(3.2. Prooftree Mode)
+SH( .)
+446 W( . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53500 XM
+(3)SH
+11200 26820 MT
+(3.2-A. POPUP MENU)
+SH( .)
+389 W( . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53500 XM
+(3)SH
+11200 27925 MT
+(3.2-B. MENU BAR . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53500 XM
+(3)SH
+11200 29030 MT
+(3.2-C. KEYS)
+SH( .)
+139 W( . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53500 XM
+(3)SH
+10200 30135 MT
+(3.3. ACL2 Mode)
+SH( .)
+667 W( . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53500 XM
+(4)SH
+11200 31240 MT
+(3.3-A. POPUP MENU)
+SH( .)
+389 W( . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53500 XM
+(4)SH
+11200 32345 MT
+(3.3-B. KEYS)
+SH( .)
+139 W( . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53500 XM
+(4)SH
+10200 33450 MT
+(3.4. Inferior ACL2 Mode)
+SH( .)
+363 W( . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53500 XM
+(4)SH
+11200 34555 MT
+(3.4-A. MENU BAR)
+SH( .)
+445 W( . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53500 XM
+(4)SH
+11200 35660 MT
+(3.4-B. INFERIOR ACL2 POPUP MENU)
+SH( .)
+333 W( . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53500 XM
+(8)SH
+11200 36765 MT
+(3.4-C. KEYS)
+SH( .)
+139 W( . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .)SH
+53500 XM
+(8)SH
+ES
+%%Trailer
+%%Pages: 10
+%%DocumentFonts: Times-Roman Times-Bold Courier-Bold Times-Italic
--- /dev/null
+++ acl2-6.0/interface/emacs/acl2-interface.el
@@ -0,0 +1,454 @@
+
+;; Add interface for various acl2 buffers.
+;; Sep 20 94 MKS 
+
+;; ----------------------------------------------------------------------
+;; USER SETTINGS
+
+;; The following controls what features of the interfaces get used.
+;; These settings mirror those in start-inferior-acl2.el.
+;; You can override these setting by setting them in your .emacs file.  
+
+;; The variable, *acl2-user-map-interface*, is an alist of modes . (list of features). 
+;; The features currently supported are: menu-bar, pop-up-menu, and keys.
+;; The default below says add them all.  
+
+;; Before the menu-bar, popup-menu or keys are defined we check
+;; the following alist to see what the user wants.
+
+(defvar *acl2-user-map-interface*
+  '((inferior-acl2-mode-map menu-bar popup-menu keys)
+    (shell-mode-map         menu-bar popup-menu keys)
+    (acl2-mode-map          menu-bar popup-menu keys)
+    (prooftree-mode-map     menu-bar popup-menu keys)))
+
+;; (defvar *acl2-proof-tree-height* 17)
+;; (defvar *checkpoint-recenter-line* 3)
+
+;; ----------------------------------------------------------------------
+;; Load all of the various acl2-interface files, if necessary.
+
+;(load "inf-acl2.el")			;(require 'inf-acl2)
+;(load "mfm-acl2.el")			;(require 'mfm-acl2)
+;(load "interface-macros.el")		;(require 'interface-macros)
+
+(require 'inf-acl2)
+(require 'mfm-acl2)
+(require 'interface-macros)
+
+(update-mode-menu-alist *acl2-user-map-interface*)
+
+;(load "acl2-interface-functions.el")
+(load "acl2-interface-functions")
+
+;; ----------------------------------------------------------------------
+;; Specials used by functions in interface-macros.el.
+
+;; MENU-BAR-FINAL-ITEMS is a global, honored by all menu-bar presentations.
+;; If the menu-bar contains any element whose car (a SYMBOL)
+;; is in it, that element will appear after any not mentioned.
+;; The ordering of MENU-BAR-FINAL-ITEMS is honored in the presentation.
+(setq menu-bar-final-items '(events help-acl2 help))
+
+(defconst general-wrapper "(acl2-wrap (acl2::%s))\n")
+(defconst verify-wrapper "(lisp %s)\n")
+(defconst acl2-wrapper   "(%s)\n")
+(defconst interface-wrapper acl2-wrapper)
+
+(setq interface-to-top  '(inf-acl2-last-line-to-top))
+(setq menu-bar-prefix   "acl2-menu-bar-%s")
+
+(setq interface-menu-function  '(inf-acl2-send-string <command> <arg>))
+(setq interface-popup-function '(inf-acl2-send-string <command> <arg>))
+
+;; These alists allow us to handle some arguments to menu and popup function
+;; differently from the defaults above.
+
+(setq menu-arg-functions
+      (append (cons 'cd
+		    '(cond ((not cd) (beep t))
+			   (t (inf-acl2-send-string <command> cd))))
+	      menu-arg-functions))
+
+(setq popup-arg-functions
+      (append (cons 'cd
+		    '(let ((thing (thing-at-click click 'symbol))
+			   (number (thing-at-click click 'number)))
+		       (cond (thing (inf-acl2-send-string <command> thing))
+			     ((and (stringp number)
+				   (numberp (setq number (int-to-string number))))
+			      (inf-acl2-send-string <command> number))
+			     (t (beep t)))))
+	      popup-arg-functions))
+
+;; ======================================================================
+;; Inferior acl2
+
+;; ----------------------------------------------------------------------
+;; Inferior acl2 menu bar.  The buffer containing the Acl2 process.
+
+(defconst inf-acl2-menu-bar
+  '((:menu "History"
+       (:entry "Recent events" "pbt '(:here -10)" :to-top)
+       (:entry "Print back through ..."  "pbt '%s" :arg event :to-top)
+
+       (:entry "Undo" "u")
+       (:entry "Oops" "oops" )
+       (:entry "Undo through ..." "ubt '%s" :arg event)
+       (:entry "Undo! through ..." "ubt! '%s" :arg cd)
+       (:label "")
+       (:entry "Load file ..." acl2-load-file)
+       (:label "")
+       (:entry "Disable ..." "in-theory (disable %s)" :arg symbol)
+       (:entry "Enable ..." "in-theory (enable %s)" :arg symbol)
+       (:label "")
+       (:entry "Verify guards ..."      "verify-guards '%s" :arg symbol)
+       (:entry "Verify termination ..." "verify-termination '%s" :arg symbol)
+       (:label "")
+       (:entry "Certify-book ..." "certify-book \"%s\"" :arg filename) ; world of 0 commands
+       (:entry "Include-book ..." "include-book \"%s\"" :arg filename)
+       (:label "")
+       (:menu "Compound commands"
+	(:entry "Expand ..." "puff '%s" :arg cd :to-top)
+	(:entry "Expand! ..." "puff* '%s" :arg cd :to-top))
+       (:menu "Table"
+	(:entry "Print value ..."    "table  %s" :arg symbol)
+	(:entry "Clear ..."          "table %s nil nil :clear" :arg symbol)
+	(:entry "Print guard ..."    "table %s nil nil :guard" :arg symbol)
+	;; ("Print element ..." "(table <arg1> <arg2>)")
+	;; ("Set element ..."   "(table <arg1> <arg2> <arg3>)")
+	;; ("Set value ..."     "(table <arg1> nil <arg2> :clear)")
+	;; ("Set Guard ..."     "(table <arg1> nil nil :guard <arg2>)")
+	))
+      (:menu "Print"
+       (:entry "Event ..." "pe '%s"  :arg event :to-top)
+       (:entry "Event! ..." "pe! '%s" :arg event :to-top)
+       (:entry "Back through ..."  "pbt '%s" :arg event :to-top)
+       
+       (:entry "Command ..." "pc '%s"  :arg cd :to-top)
+       (:entry "Command block ..." "pcb '%s" :arg cd :to-top)
+       (:entry "Full Command block ..." "pcb! '%s" :arg cd :to-top)
+
+       (:entry "Signature ..." "args '%s" :arg event :to-top)
+       (:entry "Formula ..." "pf '%s" :arg event :to-top)
+       (:entry "Properties ..." "props '%s" :arg event :to-top)
+
+       (:entry "Print connected book directory" "cbd")
+
+       (:entry "Rules whose top function symbol is ..." "pl '%s" :arg event :to-top)
+       (:entry "Rules stored by event ..." "pr '%s"   :arg event :to-top)
+       (:entry "Rules stored by command ..." "pr! '%s" :arg cd :to-top)
+
+       (:entry "Monitored-runes" "monitored-runes"))
+
+      (:menu "Control"
+       (:entry "Load ..." "ld \"%s\"" :arg filename)
+       (:entry "Compile all" "comp t")
+       (:entry "Compile ..." "comp '%s" :arg symbol)
+	
+       (:menu "Accumulated Persistence"
+	(:entry "Activate" "accumulated-persistence t")
+	(:entry "Deactivate" "accumulated-persistence nil")
+	(:menu "Display statistics ordered by" 
+	 (:entry "frames" "show-accumulated-persistence :frames")  
+	 (:entry "times tried" "show-accumulated-persistence :tries")
+	 (:entry "ratio" "show-accumulated-persistence :ratio")))
+
+       (:menu "Break rewrite"
+	(:entry "Start general rule monitoring" "brr t")
+	(:entry "Stop general rule monitoring" "brr nil")
+	(:entry "Print monitored runes"  "monitored-runes")
+	(:entry "Monitor rune: ..." "monitor '(:definition %s) 't" :arg event)
+	(:entry "Unmonitor rune: ..." "unmonitor '(:definition %s)" :arg event)
+	;; (:entry "Conditionally exit break-rewrite" "ok-if") 
+	;; Above needs an argument.
+	(:label "")
+	(:menu "Commands"
+	 (:entry "Abort to ACL2 top-level" "#." :unwrapped)
+	 (:entry "Term being rewritten" ":target" :unwrapped)
+	 (:entry "Substitution making :lhs equal :target" ":unify-subst" :unwrapped)
+	 (:entry "Hypotheses" ":hyps" :unwrapped)
+	 (:entry "Ith hypothesis ..." ":hyp %d" :arg integer :unwrapped)
+	 (:entry "Left-hand side of conclusion" ":lhs" :unwrapped)
+	 (:entry "Right-hand side of conclusion" ":rhs" :unwrapped)
+	 (:entry "Type assumptions governing :target" ":type-alist" :unwrapped)
+	 (:entry "Ttree before :eval" ":initial-ttree" :unwrapped)
+	 (:entry "Negations of backchaining hyps pursued" ":ancestors" :unwrapped)
+
+	 (:label "")
+	 (:entry "Rewrite's path from top clause to :target" ":path" :unwrapped)
+	 (:entry "Top-most frame in :path" ":top" :unwrapped)
+	 (:entry "Ith frame in :path ..." ":frame %d" :arg integer :unwrapped)
+
+	 (:label "")
+	 (:menu "AFTER :EVAL"
+	  (:entry "Did application succeed?" ":wonp" :unwrapped)
+	  (:entry "Rewritten :rhs" ":rewritten-rhs"  :unwrapped)
+	  (:entry "Ttree" ":final-ttree" :unwrapped)
+	  (:entry "Reason rule failed" ":failure-reason"  :unwrapped))
+
+	 (:menu "CONTROL"
+	  (:entry "Exit break" ":ok" :unwrapped)
+	  (:entry "Exit break, printing result" ":go" :unwrapped)
+	  (:entry "Try rule and re-enter break afterwards" ":eval" :unwrapped))
+
+	 (:menu "WITH NO RECURSIVE BREAKS"
+ 	  (:entry ":ok!" ":ok!")
+	  (:entry ":go!" ":go!")
+	  (:entry ":eval!" ":eval!"))
+
+	 (:menu "WITH RUNES MONITORED DURING RECURSION"
+  	  (:entry ":ok  ..." ":ok$ %s" :arg sexpr)
+	  (:entry ":go ..." ":go$  %s" :arg sexpr)
+	  (:entry ":eval ..." ":eval$ %s" :arg sexpr))
+	 (:label "")
+	 (:entry "Help" ":help")))
+       (:entry "Enter Acl2 Loop" "(lp)" :unwrapped)
+       (:entry "Quit to Common Lisp" ":Q" :unwrapped)
+       (:entry "ABORT" ":good-bye"))
+
+      (:menu "Settings"
+       (:menu "Mode"
+	 (:entry "Logic" "logic")
+	 (:entry "Program" "program")
+	 (:entry "Guard checking on" "set-guard-checking t")
+	 (:entry "Guard checking off" "set-guard-checking nil"))
+       (:menu "Forcing"
+	(:entry "On"  "enable-forcing")
+	(:entry "Off" "disable-forcing"))
+       (:menu "Compile functions"
+        (:entry "On"  "set-compile-fns t")
+        (:entry "Off" "set-compile-fns nil"))
+       (:menu "Proof tree"
+	 (:entry "Start prooftree" "start-proof-tree" :pre (start-proof-tree nil))
+	 (:entry "Stop prooftree" "stop-proof-tree" :post (stop-proof-tree))
+	 (:entry "Checkpoint forced goals on" "checkpoint-forced-goals t")
+	 (:entry "Checkpoint forced goals on" "checkpoint-forced-goals nil"))
+       (:menu "Inhibit Display of "
+	      (:entry "Error messages" "assign inhibit-output-lst '(error)")
+	      (:entry "Warnings" "assign inhibit-output-lst '(warning)")
+	      (:entry "Observations" "assign inhibit-output-lst '(observation)")
+	      (:entry "Proof commentary" "assign inhibit-output-lst '(prove)")
+	      (:entry "Proof tree" "assign inhibit-output-lst '(proof-tree)")
+	      (:entry "Non-proof commentary" "assign inhibit-output-lst '(event)")
+	      (:entry "Summary" "assign inhibit-output-lst '(summary)"))
+       (:menu "Unused Variables"
+	(:entry "Ignore" "set-ignore-ok t")
+	(:entry "Fail"   "set-ignore-ok nil")
+	(:entry "Warn"   "set-ignore-ok :warn"))
+       (:menu "Irrelevant formulas"
+	(:entry "Ok" "set-irrelevant-formals-ok t")
+	(:entry "Fail" "set-irrelevant-formals-ok nil")
+	(:entry "Warn" "set-irrelevant-formals-ok :warn"))
+       (:menu "Load"
+	(:menu "Error action"
+ 	 (:entry "Continue" "set-ld-error-actions :continue")
+	 (:entry "Return" "set-ld-error-actions :return")
+	 (:entry "Error" "set-ld-error-actions :error"))
+	(:menu "Error triples"
+	 (:entry "On"  "set-ld-error-triples t")
+	 (:entry "Off" "set-ld-error-triples nil"))
+	(:menu "Post eval print"
+	 (:entry "On" "set-ld-post-eval-print t")
+	 (:entry "Off" "set-ld-post-eval-print nil")
+	 (:entry "Command conventions" "set-ld-post-eval-print :command-conventions"))
+	(:menu "Pre eval filter"
+	 (:entry "All" "set-ld-pre-eval-filter :all")
+	 (:entry "Query" "set-ld-pre-eval-filter :query"))
+	(:menu "Prompt"
+  	 (:entry "On" "set-ld-prompt t")
+	 (:entry "Off" "set-ld-prompt nil"))
+	(:menu "Skip proofs" 
+	 (:entry "On" "set-ld-skip-proofs t")
+	 (:entry "Off" "set-ld-skip-proofs nil"))
+	(:menu "Verbose: on"
+	 (:entry "On" "set-ld-verbose t")
+	 (:entry "Off" "set-ld-verbose nil"))
+	(:entry "Redefinition permitted" "redef")
+	(:entry "Reset specials" "reset-ld-specials nil")
+	(:entry "Reset specials (+ I/O)" "reset-ld-specials t")
+	(:menu "HACKERS. DANGER!"		;advanced
+	 (:entry "Redefinition permitted!" "redef!"))))
+
+      (:menu "Books"	
+       (:entry "Print connected book directory" "cbd")
+       (:entry "Set connected book directory ..." "set-cbd %s" :arg filename)
+       (:entry "Certify-book ..." "certify-book \"%s\"" :arg filename)
+       (:entry "Include-book ..." "include-book \"%s\"" :arg filename))
+
+      (:menu "Acl2 Help"
+       (:entry "Documentation" "doc '%s" :arg symbol :to-top)
+       (:entry "Arguments" "args '%s" :arg symbol :to-top)
+       (:entry "More" "more")
+       (:entry "Apropos ..." "docs '%s" :arg symbol :to-top)
+       (:entry "Menu help" acl2-menu-help))))
+
+
+;; ----------------------------------------------------------------------
+;; Inferior acl2 popup menu.  The buffer containing the Acl2 process.
+
+(defconst inferior-acl2-popup
+  '((:entry "Recent events"  "pbt '(:here -10)")
+    (:entry ". Print Event"    "pe '%s" :arg event)
+    (:entry ". Print Command"  "pc '%s" :arg cd)
+    (:entry ". Print back to"  "pbt '%s" :arg cd)
+    (:entry ". Disable"        "in-theory (disable %s)" :arg event)
+    (:entry ". Enable"         "in-theory (enable %s)" :arg event)
+    (:entry "Undo"           "ubt ':here")
+    (:entry ". Undo thru"      "ubt '%s" :arg cd)
+    (:entry ". Documentation"  "doc '%s" :arg symbol)
+    (:entry ". Arguments, etc" "args '%s" :arg symbol)
+    (:label "")
+    (:entry ". Verify"         acl2-mouse-verify click)))
+
+
+;; ----------------------------------------------------------------------
+;; inferior acl2 keys
+
+(defconst inferior-acl2-keys 
+  '(("\C-x\C-e" acl2-eval-last-sexp)
+    ("\C-c\C-l" acl2-load-file)
+    ("\C-c\C-a" acl2-show-arglist)
+    ("\C-c\C-d" acl2-describe-sym)
+    ("\C-c\C-f" acl2-show-function-documentation)
+    ("\C-c\C-v" acl2-show-variable-documentation)
+    ("\C-cl"    acl2-load-file)
+    ("\C-ck"    acl2-compile-file)
+    ("\C-ca"    acl2-show-arglist)
+    ("\C-cd"    acl2-describe-sym)
+    ("\C-cf"    acl2-show-function-documentation)
+    ("\C-cv"    acl2-show-variable-documentation)))
+
+(define-interface inferior-acl2-mode inferior-acl2-mode-map
+                  inf-acl2-menu-bar
+                  '(inout completion signals)
+		  inferior-acl2-popup
+		  inferior-acl2-keys)
+
+;; ======================================================================
+;; Acl2 mode
+
+;; ----------------------------------------------------------------------
+;; Acl2 mode popup menu.  For buffers containing Acl2 code.
+
+;; For acl2-mode-map
+;; What happened to default-menu ???  We just overwrite it.
+
+(defconst acl2-menu-bar-value nil)
+
+(defconst acl2-popup-menu-value
+      '((:entry ". Send to Acl2" acl2-eval-event-at-click :arg click)
+
+	(:entry "Send region to Acl2" acl2-mouse-eval-region)
+	(:entry "Send buffer to Acl2" acl2-mouse-eval-buffer)
+
+	(:entry ". Add hint" add-hint-to-defun-at-click :arg click)
+	(:entry "Go to inferior Acl2" switch-to-acl2-eof)
+	(:entry ". Verify" acl2-mouse-verify :arg click)))
+
+(defconst acl2-keys			; due to inferior acl2
+  '(("\C-x\C-e" acl2-eval-last-sexp)
+    ("\C-c\C-r" acl2-eval-region)
+    ("\M-\C-x"  acl2-eval-event)
+    ("\C-c\C-e" acl2-eval-event)
+    ("\C-c\C-z" switch-to-acl2-eof)
+    ("\C-c\C-l" acl2-load-file)
+    ("\C-c\C-a" acl2-show-arglist)
+    ("\C-c\C-d" acl2-describe-sym)
+    ("\C-c\C-f" acl2-show-function-documentation)
+    ("\C-c\C-v" acl2-show-variable-documentation)
+    ("\C-ce"    acl2-eval-event-and-go)
+    ("\C-cr"    acl2-eval-region-and-go)))
+
+(define-interface acl2-mode acl2-mode-map
+                  acl2-menu-bar-value
+		  nil
+		  acl2-popup-menu-value
+		  acl2-keys)
+
+
+;; ======================================================================
+;; Prooftree mode
+
+;; ----------------------------------------------------------------------
+;; Prooftree mode menu-bar menu.  
+
+(defconst prooftree-menu-bar
+  '((:menu "Prooftree"
+	   (:entry "Checkpoint" acl2-menu-checkpoint)
+	   (:entry "Checkpoint / Suspend" acl2-menu-checkpoint-suspend)
+	   (:entry "Suspend proof tree" suspend-proof-tree)
+	   (:entry "Resume proof tree" resume-proof-tree)
+	   (:entry ". Goto subgoal" goto-subgoal)
+	   (:entry "Help" checkpoint-help)
+	   )))
+
+
+;; ----------------------------------------------------------------------
+;; Prooftree pop-up menu
+
+;; Unconditionally expects prooftree-mode-map to be set.
+;; Prooftree mode should have already been established by mfm-acl2.
+
+(defconst prooftree-popup-menu-value
+      '((:entry ". Checkpoint"         acl2-mouse-checkpoint :arg click)
+	(:entry ". Goto subgoal"       goto-subgoal-menu :arg click)
+	(:entry ". Checkpoint/Suspend" acl2-mouse-checkpoint-suspend :arg click)
+	(:entry "Suspend proof tree" suspend-proof-tree)
+	(:entry "Resume proof tree"  resume-proof-tree)
+	(:entry "Help"               checkpoint-help)
+	))
+
+;; Defined in mfm-acl2 so that checkpoint-help can use it.
+(defvar prooftree-subkey)
+(setq prooftree-subkey "\C-z")
+
+;; prooftree-subkeymap was set by prooftree-mode.el.  Now do it here.
+(defvar prooftree-subkeymap (make-sparse-keymap))
+
+(defvar old-prooftree-subkey (key-binding prooftree-subkey))
+
+(define-key prooftree-mode-map prooftree-subkey prooftree-subkeymap)
+
+(defconst prooftree-keys
+; WARNING: Keep this in sync with the corresponding definition in
+; key-interface.el.
+  (list
+   (list 'prooftree-subkeymap "z" old-prooftree-subkey)
+   (list 'prooftree-subkeymap "c" 'checkpoint)
+   (list 'prooftree-subkeymap "s" 'suspend-proof-tree)
+   (list 'prooftree-subkeymap "r" 'resume-proof-tree)
+   (list 'prooftree-subkeymap "g" 'goto-subgoal)
+   (list 'prooftree-subkeymap "h" 'checkpoint-help)
+   (list 'prooftree-subkeymap "?" 'checkpoint-help)
+   (list 'prooftree-subkeymap "o" 'prooftree-select-other-frame)
+   (list 'prooftree-subkeymap "b" 'visit-proof-tree)
+   (list 'prooftree-subkeymap "B" 'visit-proof-tree-other-frame)))         
+
+(define-interface prooftree-mode	;mode
+                  prooftree-mode-map	;mode-map
+                  prooftree-menu-bar
+		  nil			;menu-bar-remove
+		  prooftree-popup-menu-value
+		  prooftree-keys)
+
+;; Just in case this file gets loaded after checkpointing has started.
+;; (if (and (fboundp 'checkpoint)
+;; 	 (bufferp (get-buffer "prooftree")))
+;;     (save-excursion
+;;       (set-buffer "prooftree")
+;;       (if (not (equal major-mode 'prooftree-mode))
+;; 	(prooftree-mode)
+;; 	(run-hooks prooftree-mode-hook))))
+
+(provide 'acl2-interface)
+
+;; ======================================================================
+;; TODO: 
+;;
+;; ======================================================================
+;; LOG: 
+;;
+
+
+
--- /dev/null
+++ acl2-6.0/interface/emacs/acl2-interface-functions.el
@@ -0,0 +1,467 @@
+
+;; ----------------------------------------------------------------------
+;; Define the functions.
+
+(defvar *acl2-eval-and-go* nil)
+
+(defun acl2-eval-event-at-click (click)
+  "Go to click and execute acl2-eval-event"
+  (interactive "e")
+  (let ((posn (event-start click))
+	(end (event-end click)))
+    (select-window (posn-window posn))
+    (if (numberp (posn-point posn))
+	(goto-char (posn-point posn)))
+    ;; If mark is highlighted, no need to bounce the cursor.
+    (acl2-eval-event  *acl2-eval-and-go*)))
+
+(defun acl2-mouse-eval-region ()
+  (interactive)
+  (save-excursion
+    (let ((start (point))
+	(end (mark)))
+    (if (<= start end)
+	(acl2-eval-region start end *acl2-eval-and-go*)
+	(acl2-eval-region end start *acl2-eval-and-go*)))))
+
+(defun acl2-mouse-eval-buffer ()
+  (interactive)
+  (save-excursion (acl2-eval-region (point-min) (point-max) *acl2-eval-and-go*)))
+
+(defun this-line-to-top () (interactive) (recenter 0))
+
+(defun inf-acl2-last-line-to-top ()
+  (save-excursion
+    (set-buffer inferior-acl2-buffer)
+    (goto-char (point-max))
+    (this-line-to-top)))
+
+(defun acl2-menu-help ()
+  (interactive)
+  "Provides information about ACL2 menus, esp. where they get
+their arguments."
+  (with-output-to-temp-buffer "*Help*"
+	(princ "ACL2 Menu Use.
+-----------------------------------------------------------------
+If a menu bar entry is of the form
+
+   Print event ...
+
+the \"...\" indicates that you will be prompted in the minibuffer 
+for an argument.  The system normally tries to find a default based 
+on where the cursor is in the buffer.
+
+If a menu bar entry is of the form
+
+   Mode >
+
+the \">\" indicates that a suborninate menu will pop up if you 
+release on this menu item.
+
+Pop-up menu items indicate that they take an argument by a
+preceding \".\".  The argument is determined by what you clicked on to
+bring up the menu.  Arguments derived from things that appear in the
+chronology are somewhat robust.  So that if you had a list of events
+on the screen like:
+
+         13  (DEFMACRO TEXT (X) ...)
+ L       14  (DEFUN MSG-P (X) ...)
+ L       15  (DEFUN MAKE-PACKET (X Y Z) ...)
+ L       16  (DEFUN HISTORY-P (L) ...)
+         17  (DEFMACRO INFROM (X) ...)
+
+to see event 14 you could mouse-right anywhere on that line and select
+either \". Print Event\" or \". Print Command\".
+")))
+
+(defun acl2-mouse-verify (click)
+  (interactive "e")
+  (send-verify-sexp-to-acl2-process click))
+
+;; Sep 16 94 MKSmith - new version
+(defun send-verify-sexp-to-acl2-process (click)
+  "Writes a form consisting of `(verify ' and the region of the current buffer 
+delimited by point and the click to a temporary file.  Closes with ')\n'.
+If other-window-p is not nil the buffer is selected
+in the other window, otherwise it is selected in the current window (unless
+it is currently exposed in another window)."
+  (let* ((process (inferior-acl2-proc))
+	 (cmd-string inferior-acl2-load-command)
+	 (filename (temporary-filename (process-id process))))
+    
+    (save-excursion
+      (let ((posn (event-start click)))
+	(select-window (posn-window posn))
+	(if (numberp (posn-point posn))
+	    (goto-char (posn-point posn)))
+	(let ((b (point)))
+	  ;; WRITE-REGION has the `feature' that if start is a string
+	  ;; it gets written, rather than the region.
+	  (write-region "(acl2::verify " nil filename nil 'nomessage)
+	  (forward-sexp 1)
+	  (write-region b (point) filename t 'nomessage)
+	  (write-region ")\n" nil filename t 'nomessage))
+	(process-send-string process (format cmd-string filename))))
+    (switch-to-acl2 t)))
+
+(defvar inf-acl2-saved-menu-bar-items nil)
+
+;; These are used by the prooftree menus.
+
+(defun acl2-menu-checkpoint () (interactive) (checkpoint nil))
+
+(defun acl2-menu-checkpoint-suspend () (interactive) (checkpoint t))
+
+(defun goto-subgoal-menu (click)
+  (interactive "e")
+  (let ((posn (event-start click))
+	(end (event-end click)))
+    (select-window (posn-window posn))
+    (if (numberp (posn-point posn))
+	(goto-char (posn-point posn)))
+    (goto-subgoal (checkpoint-on-line))))
+
+(defun acl2-mouse-checkpoint (click)
+  "Go to checkpoint clicked on in the \"prooftree\" buffer with
+the character \"c\" in the first column. "
+  (interactive "e")
+  (let ((posn (event-start click))
+	(end (event-end click)))
+    (select-window (posn-window posn))
+    (if (numberp (posn-point posn))
+	(goto-char (posn-point posn)))
+    (checkpoint nil)))
+
+(defun acl2-mouse-checkpoint-suspend (click)
+  "Go to checkpoint clicked on in the \"prooftree\" buffer with
+the character \"c\" in the first column. "
+  (interactive "e")
+  (let ((posn (event-start click))
+	(end (event-end click)))
+    (select-window (posn-window posn))
+    (if (numberp (posn-point posn))
+	(goto-char (posn-point posn)))
+    (checkpoint t)))
+
+;; ----------------------------------------------------------------------
+
+(defun read-event-name-with-default ()
+  (let* (this-event
+	 (x (read-string (format "Event name (default: %s)"
+		       (setq this-event (event-at-cursor))))))
+    (if (string-equal x "")
+	this-event
+	x)))
+
+(defun read-cd-with-default () 
+  (let* (this-event
+	 (x (read-string (format "Command id (default: %s)"
+				 (setq this-event (cd-at-cursor))))))
+    (if (string-equal x "")
+	this-event
+	x)))
+
+(setq menu-interactive-arg
+      (append menu-interactive-arg 
+	      '((event   (interactive (list (read-event-name-with-default))))
+		(cd      (interactive (list (read-cd-with-default))))
+		(command (interactive (list (read-cd-with-default)))))))
+
+(setq popup-menu-interactive-arg
+      (append menu-interactive-arg
+	      '((event (interactive "e"))
+		(cd (interactive "X"))
+		(command  (interactive "X")))))
+
+(setq menu-arg-name
+      (append menu-arg-name
+	      '((cd cd) (command cd) (event event))))
+
+;; Syntax for event in history
+;;       L d     52 (DEFUN FOO (X) X)
+;;       P d     52 (DEFUN FOO (X) X)
+;;       PLd     52 (DEFUN FOO (X) X)
+;;      >           (DEFTHM TRUE-LISTP-APP
+;;      /LVd     52 (DEFUN FOO (X) X)
+;;       LV      53 (DEFUN BAR (X) (CONS X X))
+;;      \        54 (DEFUN FOO (X) X)
+
+;; In each of the following patterns the command descriptor # is in
+;;  (string-to-number (buffer-substring (match-beginning 1) (match-end 1)))
+;; And the event begins at (match-end 0), though it may not be an event.  
+
+(defconst *acl2-history-cd-line-format1*
+  "^[/\\ \t][PLV ][PLV ][d ][ \t]+\\([-0-9]+\\)[:x ]+")
+
+(defconst *acl2-history-cd-line-format2* "^>[ \t]+")
+
+(defconst *acl2-history-cd-line-format3* "^[ \trgbp]+\\([-0-9]+\\)[:x ]+"
+  "From older version of Acl2.")
+
+(defconst *acl2-def-beginning* "([Dd][Ed][Ff][a-zA-z]+[ \t]+")
+
+(defun event-at-cursor ()
+  ;; Wants to return a string = event name.
+  (save-excursion
+    (beginning-of-line) 
+    (if (save-excursion
+	  (beginning-of-line)
+	  (or (looking-at *acl2-history-cd-line-format1*)
+	      (looking-at *acl2-history-cd-line-format2*)
+	      (looking-at *acl2-history-cd-line-format3*)))
+	(goto-char (match-end 0)))
+    (if (looking-at *acl2-def-beginning*)
+	(goto-char (match-end 0)))
+    (symbol-at-cursor)))
+
+(defun cd-at-cursor ()
+  ;; Wants to return a command descriptor, preferably a number.
+  (save-excursion
+    (cond ((save-excursion
+	     (beginning-of-line)
+	     (or (looking-at *acl2-history-cd-line-format1*)
+		 (looking-at *acl2-history-cd-line-format3*)))
+	   (string-to-number (buffer-substring (match-beginning 1) (match-end 1))))
+	  ((looking-at *acl2-history-cd-line-format2*)
+	   (goto-char (match-end 0))
+	   (if (looking-at *acl2-def-beginning*)
+	       (progn (goto-char (match-end 0))))
+	   (symbol-at-cursor))
+	  (t (symbol-at-cursor)))))
+
+
+;; ----------------------------------------------------------------------
+;; More utilities
+
+(defun inferior-acl2-proc ()
+  "Returns the current inferior Acl2 process.
+See variable `inferior-acl2-buffer'."
+  (let ((proc (get-buffer-process (if (eq major-mode 'inferior-acl2-mode)
+				      (current-buffer)
+				    inferior-acl2-buffer))))
+    (or proc
+	(error "No Acl2 subprocess; see variable `inferior-acl2-buffer'"))))
+
+;; Try to unwedge Acl2.
+
+(defun acl2-abort-mystery-wedge ()
+  (interactive)
+  ;; (let ((inferior-acl2-load-command ":q\n"))
+  ;;   (acl2-send-sexp-and-go))
+  (comint-send-string (inferior-acl2-proc) ":q\n"))
+
+;;; Ancillary functions
+;;; ===================
+
+;;; Reads a string from the user.
+(defun acl2-symprompt (prompt default)
+  (list (let* ((prompt (if default
+			   (format "%s (default %s): " prompt default)
+			 (concat prompt ": ")))
+	       (ans (read-string prompt)))
+	  (if (zerop (length ans)) default ans))))
+
+
+(defvar acl2-prev-l/c-dir/file nil
+  "Record last directory and file used in loading or compiling.
+This holds a cons cell of the form `(DIRECTORY . FILE)'
+describing the last `acl2-load-file' or `acl2-compile-file' command.")
+
+(defvar acl2-source-modes '(acl2-mode)
+  "Used to determine if a buffer contains Acl2 source code.
+If it's loaded into a buffer that is in one of these major modes, it's
+considered an Acl2 source file by `acl2-load-file' and `acl2-compile-file'.
+Used by these commands to determine defaults.")
+
+(defun acl2-load-file (file-name)
+  "Load an Acl2 file into the inferior Acl2 process."
+  ;; 4th param below is NIL because LOAD doesn't need an exact name.
+  ;; But what about LD?
+  (interactive (comint-get-source "Load Acl2 file: " acl2-prev-l/c-dir/file
+				  acl2-source-modes nil)) 
+  (comint-check-source file-name) ; Check to see if buffer needs saved.
+  (setq acl2-prev-l/c-dir/file (cons (file-name-directory    file-name)
+				     (file-name-nondirectory file-name)))
+  (comint-send-string (inferior-acl2-proc)
+		      (format inferior-acl2-load-command file-name))
+  (switch-to-acl2 t))
+
+
+;; ----------------------------------------------------------------------
+;; NOT currently used
+
+;; Adapted from function-called-at-point in help.el.
+(defun acl2-fn-called-at-pt ()
+  "Returns the name of the function called in the current call.
+The value is nil if it can't find one."
+  (condition-case nil
+      (save-excursion
+	(save-restriction
+	  (narrow-to-region (max (point-min) (- (point) 1000)) (point-max))
+	  (backward-up-list 1)
+	  (forward-char 1)
+	  (let ((obj (acl2-var-at-pt)))
+	    (and (symbolp obj) obj))))
+    (error nil)))
+
+;;; Adapted from variable-at-point in help.el.
+(defun acl2-var-at-pt ()
+  (condition-case ()
+      (save-excursion
+	(forward-sexp 1)
+	(forward-sexp -1)
+	(skip-chars-forward "'")
+	(let* ((begin (point))
+	       (max (save-excursion (end-of-line) (point)))
+	       (end (- (re-search-forward "[ ,()\\.!?#|`';']" max t) 1))
+	       (obj (car (read-from-string (buffer-substring begin end)))))
+	  (and (symbolp obj) obj)))
+    (error nil)))
+
+
+;; NEEDED FOR KEY COMMANDS
+
+(defvar acl2-function-doc-command
+  "(acl2::doc '%s)\n"
+  "Command to query inferior Acl2 for a function's documentation.")
+
+(defvar acl2-var-doc-command
+  "(acl2::doc '%s)\n"
+  "Command to query inferior Acl2 for a variable's documentation.")
+
+(defvar acl2-arglist-command
+  "(acl2::args '%s)\n"
+  "Command to query inferior Acl2 for a function's arglist.")
+
+(defvar acl2-describe-sym-command
+  "(acl2::doc '%s)\n"
+  "Command to query inferior Acl2 for a variable's documentation.")
+
+(defun acl2-show-function-documentation (fn)
+  "Send a command to the inferior Acl2 to give documentation for function FN.
+See variable `acl2-function-doc-command'."
+  (interactive (acl2-symprompt "Function doc" (acl2-fn-called-at-pt)))
+  (inf-acl2-last-line-to-top)
+  (comint-proc-query (inferior-acl2-proc)
+		     (format acl2-function-doc-command fn)))
+
+(defun acl2-describe-sym (sym)
+  "Send a command to the inferior Acl2 to describe symbol SYM.
+See variable `acl2-describe-sym-command'."
+  (interactive (acl2-symprompt "Describe" (acl2-var-at-pt)))
+  (inf-acl2-last-line-to-top)
+  (comint-proc-query (inferior-acl2-proc)
+		     (format acl2-describe-sym-command sym)))
+
+(defun acl2-show-arglist (fn)
+  "Send a query to the inferior Acl2 for the arglist for function FN.
+See variable `acl2-arglist-command'."
+  (interactive (acl2-symprompt "Arglist" (acl2-fn-called-at-pt)))
+  (inf-acl2-last-line-to-top)
+  (comint-proc-query (inferior-acl2-proc) (format acl2-arglist-command fn)))
+
+(defun acl2-show-variable-documentation (var)
+  "Send a command to the inferior Acl2 to give documentation for function FN.
+See variable `acl2-var-doc-command'."
+  (interactive (acl2-symprompt "Variable doc" (acl2-var-at-pt)))
+  (inf-acl2-last-line-to-top)
+  (comint-proc-query (inferior-acl2-proc) (format acl2-var-doc-command var)))
+
+
+;; HINTS:
+;; Click in defun or defthm to add a hint.
+
+(defconst hint-x-popup-menu
+  '("Hints"
+   ("Do not induct"      ":do-not-induct t ")
+   ("Do not generalize"  ":do-not 'generalize ")
+   ("Do not fertilize"   ":do-not 'fertilize ")
+   ("Expand"    ":expand (%s) "            sexp)
+   ("Hands off" ":hands-off (%s) "         symbol)
+   ("Disable"   ":in-theory (disable %s) " symbol)
+   ("Enable"    ":in-theory (enable %s) "  symbol)
+   ("Induct"    ":induct %s "              sexp)
+   ("Cases"     ":cases (%s) "             sexp)))
+
+;; (defun foo () "bar"
+;;   (declare (xargs ... :guard-hints (("Goal" . <hints>)))))
+;; 
+;; (defthm foo "bar" body
+;;   :rule-classes (a .b)
+;;   :hints (("Goal" <hints>)))
+
+;; Need to be able to do rule classes, multiple enable, disable
+
+(defun find-hint-insertion-point ()
+  "Returns a list of the form (POINT STRING), where STRING
+is the format string in which to insert the hint, and POINT is
+where to put it"
+  (interactive)
+  (save-excursion
+    (end-of-defun)
+    (skip-chars-backward " \t\n\r\f") ;  Makes allegro happy
+    (let ((end (point)))
+      (beginning-of-defun)
+      (cond ((looking-at "(defun ") 
+	     (cond ((re-search-forward ":guard-hints[ \t]*(" end t)
+		    (cond ((re-search-forward "\"Goal\"" end t)
+			   (if (looking-at "[ \t]")
+			       (progn (forward-char 1) (list (point) "%s"))
+			       (list (point) " %s")))
+			  (t (list (point) "(\"Goal\" %s)"))))
+		   ((re-search-forward "(declare[ \t]+(xargs[ \t]+" end t)
+		    (list (point) " :guard-hints ((\"Goal\" %s)) "))
+		   (t (forward-char 1)
+		      (forward-sexp 3)
+		      (if (looking-at "[ \t]*\n")
+			  (skip-chars-forward " \t\n"))
+		      (list (point) "(declare (xargs :guard-hints ((\"Goal\" %s))))\n"))))
+	    ((looking-at "(defthm ") 
+	     (cond ((re-search-forward ":hints[ \t]*(" end t)
+		    (cond ((re-search-forward "\"Goal\"" end t)
+			   (if (looking-at "[ \t]")
+			       (progn (forward-char 1) (list (point) "%s"))
+			       (list (point) " %s")))
+			  (t (list (point) "(\"Goal\" %s)"))))
+		   (t (goto-char (- end 1))
+		      (list (point) "\n  :hints ((\"Goal\" %s))"))))
+	    (t (error "Not a function or theorem"))))))
+
+(defun add-hint-to-defun-at-click (click)
+  "Go to click, figure out where to insert, and add selected hint."
+  (interactive "e")
+  (let ((pos1 (event-start click))
+	(end (event-end click))
+	(hint (x-popup-dialog click hint-x-popup-menu)))
+    (select-window (posn-window pos1))
+    (if (numberp (posn-point pos1))
+	(goto-char (posn-point pos1)))
+    (save-excursion
+      (let* ((pair (find-hint-insertion-point))
+	     (pos (car pair))
+	     (schema (car (cdr pair)))
+	     arg)
+	(cond ((not (cdr hint)) (goto-char pos) (insert (format schema (car hint))))
+	      ((setq arg (get-hint-arg (car (cdr hint))))
+	       (goto-char pos)
+	       (insert (format schema (format (car hint) arg))))))
+      (beginning-of-defun)
+      (indent-sexp))))
+
+(defun get-hint-arg (kind)
+  (message (format "Click on %s." kind))
+  (let ((click (read-event))
+	x)
+    (setq x (thing-at-click click kind))
+    (cond ((null x) nil)
+	  ((memq kind '(event symbol)) (if (symbolp x) x))
+	  ((memq kind '(number integer)) (if (numberp x) x))
+	  ((equal kind 'filename)      (if (stringp x) x))
+	  ((memq kind '(cd command)) (if (or (numberp x) (symbolp x)) x))
+	  ((memq kind '(sexp sexpr))
+	   (if (or (numberp x) (symbolp x) (stringp x) (consp x)) x))
+	  (t nil))))
+
+(define-key acl2-mode-map [C-mouse-3] 'add-hint-to-defun-at-click)
+
+
--- /dev/null
+++ acl2-6.0/interface/emacs/acl2-mode.el
@@ -0,0 +1,143 @@
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+;; Copyright (C) 1994 Free Software Foundation, Inc.
+
+;; Author  : MKSmith (mksmith@cli.com)
+;; Begun   : Feb 27 94 
+;; Origin  : lisp-mode.el
+;; Keywords: acl2, languages
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;;; Commentary:
+
+;; The base major mode for editing Acl2 code.
+;; This mode extends very slightly lisp-mode.el (documented in the Emacs manual).
+;; See also inf-acl2.el inf-acl2-mouse.el and inf-acl2-menu.el
+
+;;; Code:
+
+(require 'lisp-mode)
+
+(defvar acl2-mode-syntax-table nil "")
+(defvar acl2-mode-abbrev-table nil "")
+
+(if (not acl2-mode-syntax-table)
+    (setq acl2-mode-syntax-table
+	  (copy-syntax-table lisp-mode-syntax-table)))
+
+(define-abbrev-table 'acl2-mode-abbrev-table ())
+
+(defun acl2-mode-variables (acl2-syntax)
+  (lisp-mode-variables nil)
+  (cond (acl2-syntax
+	  (set-syntax-table acl2-mode-syntax-table)))
+  (setq local-abbrev-table acl2-mode-abbrev-table)
+  (make-local-variable 'lisp-indent-function)
+  (setq lisp-indent-function 'acl2-indent-function))
+
+(defun acl2-shared-lisp-mode-map ()
+  "Return the shared lisp-mode-map, independent of Emacs version."
+  (if (boundp 'shared-lisp-mode-map)
+      shared-lisp-mode-map
+    lisp-mode-shared-map))
+
+(defvar acl2-mode-map nil
+  "Keymap for ordinary Acl2 mode.  All commands in 
+`acl2-shared-lisp-mode-map' are inherited by this map.")
+
+(if (not acl2-mode-map)
+    (progn
+      (setq acl2-mode-map (make-sparse-keymap))
+      (set-keymap-parent acl2-mode-map (acl2-shared-lisp-mode-map))))
+
+(defvar acl2-mode-hook nil)
+
+(defun acl2-mode ()
+  "Major mode for editing Acl2 code.
+Commands:
+Delete converts tabs to spaces as it moves back.
+Blank lines separate paragraphs.  Semicolons start comments.
+\\{acl2-mode-map}
+Note that `run-acl2' may be used either to start an inferior Acl2 job
+or to switch back to an existing one.
+
+Entry to this mode calls the value of `acl2-mode-hook'
+if that value is non-nil."
+  (interactive)
+  (kill-all-local-variables)
+  (use-local-map acl2-mode-map)
+  (setq major-mode 'acl2-mode)
+  (setq mode-name "Acl2")
+  (acl2-mode-variables t)
+  (set-syntax-table acl2-mode-syntax-table)
+  (run-hooks 'acl2-mode-hook))
+
+;; Trying this as a local variable
+;; See last entry in ACL2-MODE-VARIABLES function.
+;; (defconst lisp-indent-function 'acl2-indent-function "")
+
+(defvar last-sexp nil)
+
+;; Identical to LISP-INDENT-FUNCTION except checks acl2-indent-hook
+;; first for indentation.  Allows user to format Acl2 differently from
+;; lisp.
+(defun acl2-indent-function (indent-point state)
+  (let ((normal-indent (current-column))
+	(last-sexp (point)))
+    (goto-char (1+ (elt state 1)))
+    (parse-partial-sexp (point) last-sexp 0 t)
+    (if (and (elt state 2)
+             (not (looking-at "\\sw\\|\\s_")))
+        ;; car of form doesn't seem to be a a symbol
+        (progn
+          (if (not (> (save-excursion (forward-line 1) (point))
+                      last-sexp))
+              (progn (goto-char last-sexp)
+                     (beginning-of-line)
+                     (parse-partial-sexp (point) last-sexp 0 t)))
+          ;; Indent under the list or under the first sexp on the
+          ;; same line as last-sexp.  Note that first thing on that
+          ;; line has to be complete sexp since we are inside the
+          ;; innermost containing sexp.
+          (backward-prefix-chars)
+          (current-column))
+      (let ((function (buffer-substring (point)
+					(progn (forward-sexp 1) (point))))
+	    method)
+	(setq method (or (get (intern-soft function) 'acl2-indent-hook)
+			 (get (intern-soft function) 'lisp-indent-function)
+			 ;; Why does -hook follow -function?
+			 (get (intern-soft function) 'lisp-indent-hook)))
+	(cond ((or (eq method 'defun)
+		   (and (null method)
+			(> (length function) 3)
+			(string-match "\\`def" function)))
+	       (lisp-indent-defform state indent-point))
+	      ((integerp method)
+	       (lisp-indent-specform method state
+				     indent-point normal-indent))
+	      (method
+		(funcall method state indent-point)))))))
+
+;; (put 'progn 'lisp-indent-function 0), say, causes progn to be indented
+;; like defun if the first form is placed on the next line, otherwise
+;; it is indented like any other form (i.e. forms line up under first).
+
+(put 'if 'acl2-indent-hook nil)	;changed from 2 in lisp.
+(put 'mv-let 'acl2-indent-hook 2)
+
+(provide 'acl2-mode)
+
+;;; acl2-mode.el ends here
+
+
--- /dev/null
+++ acl2-6.0/interface/emacs/mfm.el
@@ -0,0 +1,344 @@
+;; May, 1994 [modified Oct., 1997]
+;; Matt Kaufmann and Mike Smith
+
+;; This file lets one attach a filter and a collection of buffers to a
+;; process in emacs.  See mfm-acl2.el for an example of how to use the
+;; utilities in this file.  It should work in emacs version 18, emacs version
+;; 19 with comint, and version 19 with an old-style shell (Bill Schelter's
+;; sshell.el).
+
+;; If using this with buffers that use comint for processes, it's a good idea
+;; to (setq mfm-comint-p t) in one's .emacs file.  Otherwise, this file uses
+;; comint (i.e., mfm-comint-p is t) if and only if the emacs version is 19 or
+;; later and Schelter's sshell is not present as a feature.
+
+;; Possible future extensions:
+
+; Consider saving the buffer's process filter before installing our
+; own, and restoring it when executing stop-proof-tree.  This is also
+; important to do when we change the *mfm-buffer*.
+
+; Think about the effect of renaming a shell buffer.
+
+; Create a way for #<\<e ... #>\> to cause the form to be read into
+; emacs and evaluated.
+
+(defvar mfm-emacs-version
+  (if (and (boundp 'emacs-version)
+           (stringp emacs-version)
+           (< 1 (length emacs-version))
+           (string-match "[0-9][0-9]" (substring emacs-version 0 2)))
+      (string-to-int (substring emacs-version 0 2))
+    (error "The file mfm.el works for emacs versions 18 and 19, but not yours.")))
+
+(defvar mfm-comint-p
+  (and (<= 19 mfm-emacs-version)
+       (not (featurep 'sshell))))
+
+; For the byte compiler:
+
+(defvar last-input-end)
+(defvar comint-last-input-end)
+(defvar comint-output-filter-functions)
+(defvar comint-last-output-start)
+
+(defun mfm-update-last-input-end (nchars)
+  (let ((end (if mfm-comint-p 
+                 comint-last-input-end
+               last-input-end)))
+    (if (and end
+             (marker-buffer end)
+             (= (point) end))
+        (set-marker end (- end nchars)))))
+
+(defun mfm-update-last-output-start (ostart)
+  (if mfm-comint-p
+      (set-marker comint-last-output-start ostart)
+    nil))
+
+(defun mfm-force-mode-line-update ()
+  (if mfm-comint-p
+      (force-mode-line-update)
+    nil))
+
+; e.g., "*shell*"
+(defvar *mfm-buffer* nil)
+
+; The following is adapted from a contribution from Noah Friedman, from his
+; ftelet mode.
+(defun ftelnet-carriage-filter (string)
+  (let* ((point-marker (point-marker))
+         (proc (get-buffer-process (current-buffer)))
+         (end (if proc (process-mark proc) (point-max)))
+         (beg (or (and proc
+                       (boundp 'comint-last-output-start)
+                       comint-last-output-start)
+                  (- end (length string)))))
+    (goto-char beg)
+    (while (search-forward "\C-m" end t)
+      (delete-char -1))
+    (goto-char point-marker)))
+
+(defvar *mfm-secondary-filter-functions* '(ftelnet-carriage-filter))
+
+(defvar *mfm-secondary-buffer* nil
+  "This variable is NIL if we are not currently accumulating output
+to the secondary buffer.  If we are its value is that buffer.")
+
+(defvar *mfm-secondary-buffer-name-alist* nil)
+
+; We were relying on the rarity of the breaking up of a string #<\<0 or
+; #>\>  So far so good, said the guy falling past the 82nd floor....
+; Broke.  So we are fixing it.
+
+(defvar *mfm-protocol-start* "#"
+  "Character used to start and stop redirection.")
+
+(defun mfm-initial-secondary-start ()
+  (format "#<[\\]<[%s]" 
+          (apply 'concat
+                 (mapcar 'char-to-string
+                         (mapcar 'car
+                                 (mapcar 'cdr
+                                         *mfm-secondary-buffer-name-alist*))))))
+
+(defvar *mfm-secondary-start*
+  (mfm-initial-secondary-start))
+
+(defvar *mfm-secondary-stop* "#>[\\]>")
+
+; The value of *mfm-secondary-stop-len* should be the length of any string that
+; matches *mfm-secondary-stop*.
+(defvar *mfm-secondary-stop-len* 4)
+
+(defvar *mfm-paused-buffers* nil)
+
+(defvar *mfm-secondary-buffer-alist* nil)
+
+(defun mfm-output-filter-functions ()
+  (if mfm-comint-p
+      (delete t comint-output-filter-functions)
+    nil))
+
+(defun mfm-paused-buffers (alist)
+  (if (null alist)
+      nil
+    (if (memq 'pause (cdr (cdr (car alist))))
+        (cons (car (car alist))
+              (mfm-paused-buffers (cdr alist)))
+      (mfm-paused-buffers (cdr alist)))))
+
+(defun mfm-create-buffers-from-secondary-buffer-name-alist ()
+  ;; This is OK even if some or all of the buffers already exist.
+  (setq *mfm-secondary-buffer-alist*
+	(mapcar (function (lambda (pair)
+			    (cons (car (cdr pair))
+				  (get-buffer-create (car pair)))))
+		*mfm-secondary-buffer-name-alist*)))
+
+(defun mfm-initialize-secondary-buffer-alist ()
+  (mfm-create-buffers-from-secondary-buffer-name-alist)
+  (setq *mfm-paused-buffers*
+        (mfm-paused-buffers *mfm-secondary-buffer-name-alist*))
+  (setq *mfm-secondary-start*
+        (mfm-initial-secondary-start)))
+
+(defvar *mfm-saved-tail* "")
+(defvar *mfm-secondary-text* "")
+
+(defun mfm-string-start (string)
+  ;; Return nil or pair.
+  ;; If pair = (n NIL), then we have a match for *mfm-secondary-start* at n.
+  ;; If pair = (n T),   then we have a match for *mfm-protocol-start* at n, and
+  ;;  n indexs one of the last four characters of string.
+  (let ((start (string-match *mfm-secondary-start* string)))
+    (cond (start (list start nil))
+	  ((string-match *mfm-protocol-start* string (max (- (length string) 4) 0))
+	   (list (match-beginning 0) t))
+	  (t nil))))
+
+(defun mfm-string-stop (string)
+  ;; Return nil or pair.
+  ;; If pair = (n NIL), then we have a match for *mfm-secondary-stop* at n;
+  ;; elseif pair = (n T), then we have a match for *mfm-protocol-start* at n,
+  ;; and n indexes one of the last four characters of string.
+  (let ((stop (string-match *mfm-secondary-stop* string)))
+    (cond (stop (list stop nil))
+	  ((string-match *mfm-protocol-start*
+                         string
+                         (max (- (length string) 3) 0))
+	   (list (match-beginning 0) t))
+	  (t nil))))
+
+(defun mfm-output-filter (process string)
+  ;; At this point we need to check if secondary start or stop
+  ;; is contained in string.
+  ;; Previously error prone in case of xxx START xx START xx STOP xx STOP xx...
+  ;; Modified to handle start and stop broken across successive strings.
+  ;; E.g., xxxSTA RTxxxx xxxxST OPxxx
+  (setq string (concat *mfm-saved-tail* string))
+  (setq *mfm-saved-tail* "")
+  (if *mfm-secondary-buffer*
+      ;; We are currently writing to one of the secondary buffers.
+      (let ((stop (mfm-string-stop string)))
+	(cond ((null stop)
+	       (setq *mfm-secondary-text*
+		       (concat *mfm-secondary-text* string)))
+	      ((null (car (cdr stop)))
+	       (setq stop (car stop))
+               ;; Write the accumulated text, including the appropriate part of
+               ;; STRING.  First write the current point as the first line.
+	       (mfm-output-to-secondary
+                *mfm-secondary-buffer*
+                (concat *mfm-secondary-text*
+                        (substring string 0 stop)))
+               (setq *mfm-secondary-buffer* nil)
+	       (setq *mfm-secondary-text* "")
+	       (mfm-output-filter
+		process
+		(substring string (+ stop *mfm-secondary-stop-len*))))
+	      ((car (cdr stop))
+	       (setq stop (car stop))
+	       ;; May or may not be done.
+	       ;; Add the accumulated text to *mfm-secondary-text*.
+	       (setq *mfm-secondary-text*
+		       (concat *mfm-secondary-text* (substring string 0 stop)))
+	       (setq *mfm-saved-tail* (substring string stop)))))
+
+    (let* ((start (mfm-string-start string))
+           (end (and start (match-end 0))))
+      (cond ((null start) (mfm-output-to-primary process string))
+            ((null (car (cdr start)))
+	     (setq start (car start))
+             ;; Write the appropriate part of STRING to primary output
+             ;; Then enter secondary buffer mode.
+             (mfm-output-to-primary process
+                                    (substring string 0 start))
+             (setq *mfm-secondary-buffer*
+                   (cdr (assq (aref string (1- end))
+                              *mfm-secondary-buffer-alist*)))
+             (if (null (buffer-name *mfm-secondary-buffer*))
+                 (progn (mfm-create-buffers-from-secondary-buffer-name-alist)
+                        (setq *mfm-secondary-buffer*
+                              (cdr (assq (aref string (1- end))
+                                         *mfm-secondary-buffer-alist*)))))
+             (mfm-output-filter process (substring string end)))
+	    ((car (cdr start))
+	     (setq start (car start))
+	     (mfm-output-to-primary process (substring string 0 start))
+	     (setq *mfm-saved-tail* (substring string start)))))))
+
+(defun mfm-output-to-primary (process string)
+  ;; First check for killed buffer
+  (let ((oprocbuf (process-buffer process)))
+    (if (and oprocbuf (buffer-name oprocbuf))
+        (let ((obuf (current-buffer))
+              (opoint nil) (obeg nil) (oend nil))
+          (set-buffer oprocbuf)
+          (setq opoint (point))
+          (setq obeg (point-min))
+          (setq oend (point-max))
+          (let ((buffer-read-only nil)
+                (nchars (length string))
+                (ostart nil))
+            (widen)
+            (goto-char (process-mark process))
+            (setq ostart (point))
+            (if (<= (point) opoint)
+                (setq opoint (+ opoint nchars)))
+            ;; Insert after old_begv, but before old_zv.
+            (if (< (point) obeg)
+                (setq obeg (+ obeg nchars)))
+            (if (<= (point) oend)
+                (setq oend (+ oend nchars)))
+            (insert-before-markers string)
+            ;; Don't insert initial prompt outside the top of the window.
+            (if (= (window-start (selected-window)) (point))
+                (set-window-start (selected-window) (- (point) (length string))))
+            (mfm-update-last-input-end nchars)
+            (mfm-update-last-output-start ostart)
+            (set-marker (process-mark process) (point))
+            (mfm-force-mode-line-update))
+
+          (narrow-to-region obeg oend)
+          (goto-char opoint)
+          (ftelnet-carriage-filter string)
+          (let ((functions (mfm-output-filter-functions)))
+            (while functions
+              (funcall (car functions) string)
+              (setq functions (cdr functions))))
+          (set-buffer obuf)))))
+
+(defun member-equal (a lst)
+  ;; because member is not defined in version 18
+  (if (null lst)
+      nil
+    (if (equal a (car lst))
+        lst
+      (member-equal a (cdr lst)))))
+
+(defun mfm-paused-p (buffer-name)
+  (member-equal buffer-name *mfm-paused-buffers*))
+
+(defun mfm-output-to-secondary (oprocbuf string)
+  ;; First check that buffer exists.
+  (if (and oprocbuf (buffer-name oprocbuf))
+      (let ((obuf (current-buffer)))
+        (if ; Stop output to "pause" buffers.
+            (mfm-paused-p (buffer-name oprocbuf))
+            nil
+          (set-buffer oprocbuf)
+          ;; Clear buffer before displaying string.
+          (delete-region (point-min) (point-max))
+          (let ((buffer-read-only nil))
+            (insert string))
+          (mfm-force-mode-line-update)
+          (let ((functions *mfm-secondary-filter-functions*))
+            (while functions
+              (funcall (car functions) string)
+              (setq functions (cdr functions))))
+          (set-buffer obuf)))))
+
+(defun mfm-abort-secondary-buffer ()
+
+  "Flush the text currently being sent to the secondary buffer and
+resume sending text to primary buffer.  This does not stop or pause
+the sending of output to secondary buffers; it merely flushes the
+current stream being sent to a secondary buffer (if any)."
+
+  (interactive)
+  (setq *mfm-secondary-buffer* nil)
+  (setq *mfm-saved-tail* "")
+  (setq *mfm-secondary-text* ""))
+
+(defun mfm-interrupt-subjob ()
+  (interactive)
+  (progn
+    (mfm-abort-secondary-buffer)
+    ;; use funcall here to avoid confusing the compiler
+    (if mfm-comint-p
+        (if (eq major-mode 'telnet-mode)
+            (funcall 'telnet-interrupt-subjob)
+          (funcall 'comint-interrupt-subjob))
+      (funcall 'interrupt-shell-subjob))))
+
+(defun mfm-set-keymap-interrupt ()
+  (save-excursion
+    (if *mfm-buffer*
+        (progn (set-buffer *mfm-buffer*)
+               (define-key (current-local-map)
+                 "\C-C\C-C"
+                 'mfm-interrupt-subjob)))))
+
+(defun mfm-select-buffer-window (buffer)
+
+  "Select a window containing the given buffer if there is one; otherwise, make
+the current window fill the frame, and select the indicated buffer."
+  (let ((w (get-buffer-window buffer)))
+    (if w
+        (select-window w)
+      (progn (delete-other-windows)
+             (switch-to-buffer buffer)))))
+
+(provide 'mfm)
+
--- /dev/null
+++ acl2-6.0/interface/emacs/interface-macros.el
@@ -0,0 +1,644 @@
+;; Macros to uniformly define emacs interface commands.
+;; Specifically:
+
+;;  1. Set the menu-bar.
+;;  2. Set up a pop-up menu on mouse-3.
+;;  3. Set other random key definitions.
+;;
+;; Originally designed for Acl2.
+;; For versions of Emacs post 19 running under X.
+
+(require 'thingatpt)			; (load "thingatpt")	
+(require 'mouse)			; (load "mouse")
+
+(provide 'interface-macros)
+
+(defvar mode-menu-alist nil)
+(defvar menu-bar-prefix "menu-bar-%s")
+
+(defvar interface-wrapper "%s")
+(defvar interface-to-top '(this-line-to-top))
+
+;; Default form for evaluating a generated command. 
+;; <command> is replaced by the command string in the menu, and
+;; <arg> by the value of the computed argument (or nil) depending on
+;; the arg description in the menu.
+;; Example: '(inf-acl2-send-string <command> <arg>)
+
+(defvar menu-arg-functions nil)
+(defvar interface-menu-function nil)
+
+;; The following two alists allow you to override the defaults 
+;; above in the case of particular argument types.
+;; Should be list of form ((argtype . expr)), where expr
+;; may contain <command> and <arg>  which get replaced as for the
+;; above.
+(defvar popup-arg-functions nil)
+(defvar interface-popup-function nil)
+
+;; The mouse gesture that popup menus are hung off.  I think
+;; it is important that this be a DOWN command.
+
+(defvar down-mouse [down-mouse-3])
+
+
+;; Interface definition form:
+
+;; (define-interface mode mode-map menu-bar menu-bar-remove popup-menu keys)
+
+;; Before the menu-bar, popup-menu or keys are defined we check
+;; MODE-MENU-ALIST to see if the map named mode-map requests that functionality.
+
+;; WARNING:  Be sure that if should-i-install, update-mode-menu-alist,
+;; remove-mode-menu-alist, define-mode-keys, or extend-hook is changed, then it
+;; is also changed in key-interface.el.
+
+(defun should-i-install (mode feature)
+  ;; mode is mode-name
+  (memq feature (cdr (assoc mode mode-menu-alist))))
+
+(defun update-mode-menu-alist (l)
+  (if (not (consp (car l)))
+      (setq l (cons l nil)))
+  (setq mode-menu-alist 
+	(append l (remove-mode-menu-alist mode-menu-alist l))))
+
+(defun remove-mode-menu-alist (alist l)
+  (cond ((null alist) l)
+	((assoc (car (car alist)) l)
+	 (remove-mode-menu-alist (cdr alist) l))
+	(t (cons (car alist) (remove-mode-menu-alist (cdr alist) l)))))
+
+;; ----------------------------------------------------------------------
+;; MENU
+;;
+;; menu      ::= (command*)
+;; command   ::=    (:entry label string . keywords)
+;;               || (:entry label symbol . keywords) ; (fboundp symbol)
+;;               || (:keymap label symbol) ; (keymapp (eval symbol))
+;;               || (:menu label . menu)
+;;               || (:label string)
+;; keywords  ::= ([:arg arg] [:to-top] [:unwrapped] :pre :post)
+;; arg       ::= symbol || integer || string || sexp ||  click
+
+;; arg may be extended. For example acl2-interface-functions adds event,
+;; cd, and command.  The last two stand for command-descriptors.
+
+;; Commands: generate entries in the menu. 
+;;  :entry label string : Causes string (wrapped) to be sent to process.
+;;  :entry label symbol : Invokes function named symbol.
+;;  :menu label . menu  : Recurs on menu defined by menu.
+;;  :label string       : Just puts string in menu, for example as documentation
+;;                        or to provide a blank line (:label "").
+;; Keywords:
+;;  a. :TO-TOP instructs the interface to put the current point at the top of
+;;     the buffer before executing the command.  Default is to do nothing.
+;;  b. Normally the strings in entries are inserted into a "wrapper", the value
+;;     of INTERFACE-WRAPPER.  :UNWRAPPED instructs the interface to skip this step.
+;;  c. :arg indicates that an argument of the indicated type must
+;;     be supplied.
+;;  d. :pre indicates an emacs form to be evaled before anything else.
+;;  e. :post indicates an emacs form to be evaled after everything else.
+
+(defmacro when (test &rest body) (cons 'if (cons test (list (cons 'progn body)))))
+
+(defun extend-menu-bar (map-name key menu &optional function-prefix)
+  "MAP-NAME is keymap name. KEY is a key vector, typically 
+\[menu-bar\].  TREE is menu-tree."
+  (if (null function-prefix) (setq function-prefix menu-bar-prefix))
+  (cond ((not (keymapp (eval map-name))) (error (format "%s is not a keymap name." map-name)))
+	((should-i-install map-name 'menu-bar)
+	 (let ((map (eval map-name)))
+	   (or (lookup-key map key)
+               (define-key map key (make-sparse-keymap)))
+           (define-menus map key menu function-prefix)))))
+
+(defun define-menus (map key menu prefix)
+  ;; key is a vector, e.g. [menu-bar].
+  ;; It is the key in map that menu is supposed to hang off.
+  ;; So that menus will come out looking like the user typed them in
+  ;; we reverse the menu list first.
+  (setq menu (reverse menu))
+  (while menu
+    (let ((entry (car menu)))
+      (cond ((not (consp entry)) (error "Ill formed menu-tree")) 
+	    ((equal (car entry) ':menu)
+	     (let ((label (car (cdr entry)))
+		   (menu (cdr (cdr entry))))
+	       (define-key map (extend-key-vector key label)
+		 (cons label (make-sparse-keymap label)))
+	       (define-menus map (extend-key-vector key label) menu (concat prefix "-" label))))
+	    ((equal (car entry) ':label)
+	     (define-key map (extend-key-vector key (nth 1 entry)) (cons (nth 1 entry) nil)))
+	    ((equal (car entry) ':entry)
+	     (define-menu-function map key entry prefix))
+	    (t (error (format "Bad menu %s" entry)))))
+    (setq menu (cdr menu))))
+
+(defun define-menu-function (map key entry prefix)
+  (let ((label (nth 1 entry))
+	(function (nth 2 entry))
+	(function-name (make-function-name prefix (nth 1 entry)))
+	(arg (menu-get-arg entry))
+	;; TODO. Special purpose.  Need to generalize. 
+	(pre  (get-keyword-value ':pre entry))
+	(post (get-keyword-value ':post entry))
+	(to-top (memq ':to-top entry))
+	(wrapped-p (not (memq ':unwrapped entry))))
+    (cond ((stringp function)
+	   (eval (menu-function function-name arg function to-top wrapped-p nil pre post))
+	   (define-key map (extend-key-vector key label) (cons label function-name)))
+	  ((not (symbolp function)) (error (format "Bad menu entry %s" entry)))
+	  ((fboundp function)
+	   (if (or pre post) (error (format "Pre or post not allowed with function: %s" entry)))
+	   (define-key map (extend-key-vector key label) (cons label function)))
+	  ((keymapp (eval function))
+	   (define-key map (extend-key-vector key label) (cons label function)))
+	  (t (error (format "Bad menu entry %s" entry))))))
+
+;; ----------------------------------------------------------------------
+;; Popup Menus
+
+(defun interface-noop () nil)
+
+;; My simple hack for inserting labels doesn't work if any two labels
+;; are the same.  Only the last one shows up.
+
+(defun define-popup-menu (map-name menu-name entries)
+  "MAP-NAME is a keymap name.  MENU-NAME must be bound to a menu-tree."
+  (let ((map (eval map-name))
+	function-name)
+    (cond ((not (keymapp map)) (error (format "%s is not a keymap name." map-name)))
+	  ((should-i-install map-name 'popup-menu)
+	   ;; Initialize-popup-menu defines the function that is called when
+	   ;; the mouse button is pressed.  Creates menu named menu-name.
+	   (setq function-name (initialize-popup-menu menu-name))
+	   (define-key map down-mouse (cons "Doesnt print" function-name))
+	   ;; So that menus will come out looking like the user typed them in
+	   ;; we reverse the menu list first.
+	   (setq entries (reverse entries))
+	   (while entries
+	     (define-popup-menu-item menu-name (car entries))
+	     (setq entries (cdr entries)))))))
+
+(defun define-popup-menu-item (menu-name entry)
+  ;; entry ::= (:entry "label" [function or string] . keys)
+  (let* ((label (nth 1 entry))
+	 (operation (nth 2 entry))
+	 (function-name (make-function-name menu-name label))
+	 (arg (menu-get-arg entry))
+	 ;; TODO. Special purpose.  Need to generalize. 
+	 (pre  (get-keyword-value ':pre entry))
+	 (post (get-keyword-value ':post entry))
+	 (to-top (memq ':to-top entry))
+	 (wrapped-p (not (memq ':unwrapped entry))))
+    ;;
+    (cond ((equal (car entry) ':label)
+	   (define-key (eval menu-name) (make-key-vector 'interface-noop)
+	     (cons label nil)))
+	  ((not (equal (car entry) ':entry))
+	   (error (format "%s not allowable entry for popup meunu %s"
+			  entry menu-name)))
+	  ((stringp operation)
+	   ;; Create the function.
+	   (eval (menu-function function-name arg operation to-top  wrapped-p 'popup pre post))
+	   (put function-name menu-name arg)
+	   (define-key (eval menu-name) (make-key-vector function-name) (cons label t)))
+	  ((not (symbolp operation))
+	   (error (format "Bad popup function in %s" entry)))
+	  ((fboundp operation) (setq function-name operation)
+	   (if (or pre post) (error (format "Pre or post not allowed with function: %s" entry)))
+	   (put function-name menu-name arg)
+	   (define-key (eval menu-name) (make-key-vector function-name) (cons label t)))
+	  (t (error (format "Undefined popup function in %" entry))))))
+
+(defun initialize-popup-menu (menu-name)
+  ;; Defines a menu named (car menu) as a subpart of map.
+  ;; Defines the menu select function, MENU-NAME-SELECT, to
+  ;; be hung off of a mouse key.
+  (let ((function-name (intern (concat (symbol-name menu-name) "-select"))))
+    (set menu-name (make-sparse-keymap))
+    (define-selection-function function-name menu-name)
+    function-name))
+
+(defun define-selection-function (function-name menu-name)
+  (eval
+   (acl2-substitute
+    (list (cons '*menu-select* function-name)
+	  (cons '*menu* menu-name))
+    '(defun *menu-select* (click)
+       "This function is invoked in foo mode by mouse-3"
+       (interactive "e")
+       ;; replace (new-mouse-position) with click
+       (let ((action (x-popup-menu click *menu*))
+	     args)
+	 (if (consp action) (setq action (car action)))
+	 (if (not (symbolp action))
+	     (error "MENU ACTION MUST BE A SYMBOLP"))
+	 (setq args (get action '*menu*))
+	 ;; First case indicates we abandoned the menu without selecting anything.
+	 (cond ((null action) nil)
+	       ((null args)    (apply action nil))
+	       ((numberp args) (apply action (list args)))
+	       ((equal args t) (apply action (list t)))
+	       ((eq args 'click) (apply action (list click)))
+	       ((memq args '(buffer filename line word sentence sexp symbol number list event cd))
+		(apply action (list (thing-at-click click args))))
+	       ;; Default assumes that the args you have supplied are
+	       ;; to be evaled.
+	       (t (apply action (mapcar (function eval) args)))))))))
+	    
+(defun menu-function (name arg command &optional to-top wrapped-p popup pre post)
+  (let ((arg-name (defmenu-arg-name arg popup))
+	(interactive (defmenu-interactive-arg arg popup))
+	body)
+    ;; COMMAND must be string.
+    (if wrapped-p (setq command (format interface-wrapper command)))
+    (setq body (menu-function-body command arg-name popup))
+    (append (list 'defun
+		  name
+		  (if arg-name (list arg-name) ())
+		  interactive)
+	    (if pre (list pre))
+	    (if to-top
+		(list interface-to-top
+		      body)
+		(list body))
+	    (if post (list post)))))
+
+(defvar menu-keyword-list '(:arg :to-top :unwrapped :pre :post))
+
+(defun menu-keywordp (x) (memq x menu-keyword-list))
+
+(defun menu-get-arg (l)
+  ;; l is an entry.
+  ;; form is (:entry label symbol . keys)
+  ;; also allow, because it is a mistake made repeatedly,
+  ;; (:entry label symbol arg . keys)
+  (let ((x (memq ':arg l)))
+    (cond (x (nth 1 x))
+	  ((and (equal (car l) ':entry)
+		(> (length l) 3)
+		(not (menu-keywordp (nth 3 l))))
+	   (nth 3 l))
+	  (t nil))))
+
+(defun get-keyword-value (key l)
+  ;; l is an entry.
+  ;; form is (:entry label symbol . keys)
+  (let ((x (member-equal key (cdr l))))
+    (cond (x (nth 1 x))
+	  (t nil))))
+
+;; Mouse event naming:
+
+;; [ modifiers ][ number ][ kind ] MOUSE button
+;; button    := -1  -2  -3
+;; modifiers := C-  M-  H-  s-  A-  S-
+;; number    := double-  triple-
+;; kind      := drag-  down-  up-
+
+;; Dummy prefix keys and their meanings:
+
+;; mode-line             The mouse was in the mode line of a window.
+;; vertical-line         The mouse was in the vertical line separating side-by-side windows.
+;; vertical-scroll-bar   The mouse was in a vertical scroll bar.
+;; horizontal-scroll-bar The mouse was in a horizontal scroll bar.  Rare.
+
+;; Click accessors
+;; (down-mouse-3 (#<window 43 on *scratch*> 236 (53 . 8) 1222667))
+;;               |
+;;               event-start
+;; (#<window 43 on *scratch*> 236 (53 . 8) 1222667)
+;;  |                         |   |
+;;  posn-window               |   posn-col-row 
+;;                            posn-point 
+
+
+;; ----------------------------------------------------------------------
+;; Menu-bar utilities
+
+(defun remove-from-menu-bar (remove map)
+  ;; Delete menu-bar items whose labels match the strings in REMOVE.
+  (when map
+    (mapcar
+     (function (lambda (x) (define-key map (extend-key-vector [menu-bar] x) nil)))
+     remove)))
+
+;; MENU-BAR-FINAL-ITEMS is a global, honored by all menu-bar
+;; presentations.  If the menu-bar contains any element whose car (a
+;; SYMBOL) is in it, that element will appear after any not mentioned.
+;; The ordering provided by MENU-BAR-FINAL-ITEMS is honored.  
+;; (setq  menu-bar-final-items final)
+
+
+;; ----------------------------------------------------------------------
+;; Menu function definition and argument extraction/translation
+
+(defconst menu-arg-name
+  '((click click)
+    (number number) (integer number)
+    (sexp sexp) (sexpr sexp)
+    (file file) (filename file) 
+    (symbol symbol)))
+
+(defun defmenu-arg-name (x &optional popup)
+  (if (assoc x menu-arg-name)
+      (car (cdr (assoc x menu-arg-name)))
+      x))
+
+(defconst menu-interactive-arg 
+  '((click    (interactive "e"))
+    (symbol   (interactive (list (read-symbol-with-default))))
+    (integer  (interactive (list (read-number-with-default))))
+    (number   (interactive (list (read-number-with-default))))
+    (file     (interactive "f"))
+    (filename (interactive "f"))
+    (sexpr    (interactive "X"))
+    (sexp     (interactive "X"))))
+
+(defconst popup-menu-interactive-arg 
+  '((symbol   (interactive "S"))
+    (integer  (interactive "n"))
+    (number   (interactive "n"))
+    (file     (interactive "f"))
+    (filename (interactive "f"))
+    (sexpr    (interactive "X"))
+    (sexp     (interactive "X"))))
+    
+(defun defmenu-interactive-arg (kind &optional popup)
+  (if (not popup)
+      (cond ((null kind) '(interactive))
+	    ((assoc kind menu-interactive-arg)
+	     (car (cdr (assoc kind menu-interactive-arg))))
+	    (t (cond ((stringp kind) (list 'interactive kind))
+		     (t (error (format "Don't recognize %s for menu-bar" kind popup))))))
+      ;; The way these functions are called precludes any real use
+      ;; of the interactive call to obtain the argument.
+      ;; BUT, the argument types should match.
+      (cond ((null kind) '(interactive))
+	    ((assoc kind popup-menu-interactive-arg)
+	     (car (cdr (assoc kind popup-menu-interactive-arg))))
+	    (t (cond ((stringp kind) (list 'interactive kind))
+		     (t (error (format "Don't recognize %s for popups" kind))))))))
+
+
+;; The basic EMACS wrapper to send a command to the process buffer.
+;; Some arg types may require special handling, in which case they
+;; are in one or both of the `-arg-functions' alists.
+
+(defun menu-function-body (command arg &optional popup)
+  (let ((body (cdr (assoc arg (if popup popup-arg-functions menu-arg-functions)))))
+    (if (not body)
+	(if popup
+	    (setq body interface-popup-function)
+	    (setq body interface-menu-function)))
+    (subst arg '<arg> (subst command '<command> body))))
+
+
+;; ----------------------------------------------------------------------
+;; Popup Utiliites
+
+(defun new-mouse-position ()
+  (let ((x (mouse-position)))
+    (list (list (car (cdr x)) (cdr (cdr x))) (car x))))
+
+(defun acl2-substitute (alist form)
+  (cond ((not (consp form))
+	 (let ((pair (assoc form alist)))
+	   (if pair (cdr pair) form)))
+	(t (cons (acl2-substitute alist (car form))
+		 (acl2-substitute alist (cdr form))))))
+
+(defun subst (new old form)
+  (cond ((equal form old) new)
+	((not (consp form)) form)
+	(t (cons (subst new old (car form))
+		 (subst new old (cdr form))))))
+
+(defun this-line-to-top () (interactive) (recenter 0))
+
+;; ----------------------------------------------------------------------
+;; Parsing objects out of the emacs buffer.
+
+(defun thing-at-click (click type)
+  (save-excursion 
+    (select-window (posn-window (event-start click)))
+    (goto-char (posn-point (event-start click)))
+    (cond ((eq type 'symbol) (symbol-at-point))
+	  ((eq type 'number) (number-at-point))
+	  ((eq type 'list)   (list-at-point))
+	  ((eq type 'sexp)   (find-sexp)(sexp-at-point))
+	  ;; Shouldn't be in this file
+	  ((eq type 'cd)     (cd-at-cursor)) 
+	  ((eq type 'event)  (event-at-cursor))
+	  (t (thing-at-point type)))))
+
+(defun find-sexp ()
+  (interactive)
+  (cond ((looking-at "[ \t\n]+")
+	 (re-search-forward "[^ \t\n]" nil nil)(backward-char 1))
+	((looking-at ")") (forward-sexp -1))
+	((re-search-backward "[ \t\n(\"]" nil nil) (forward-char 1))
+	(t nil)))
+
+
+;; ----------------------------------------------------------------------
+;; Making new names and key vectors
+
+(defun extract-menu-name (string)
+  (let ((x (string-match "[ -\.]" string)))
+    (cond ((null x) string)
+	  ((zerop x) 
+	   (if (> (length string) 0)
+	       (extract-menu-name (substring string 1))
+	       (makeup-menu-name)))
+	  (t (substring string 0 x)))))
+
+(defvar makeup-index 1)
+
+(defun makeup-menu-name ()
+  (let ((s (format nil "BOGUS-~S" makeup-index)))
+    (setq makeup-index (+ makeup-index 1))
+    s))
+
+(defun make-key-vector (name)
+  (if (stringp name)
+      (setq name (intern (remove-blanks name))))
+  (make-vector 1 name))
+
+(defun extend-key-vector (vector name)
+  (if (stringp name)
+      (setq name (intern (remove-blanks name))))
+  (vconcat vector (make-vector 1 name)))
+
+(defun remove-blanks (name)
+  (setq name (copy-sequence name))
+  (let ((n (length name))
+	(i 0))
+    (while (< i n)
+      (if (char-equal (aref name i) ?\ )
+	  (aset name i ?-))
+      (setq i (+ i 1)))
+    name))
+
+(defun mk-symbol (a b)
+  (cond ((string-match "%" a) (intern (format a b)))
+	(t (intern (concat a b)))))
+
+(defun make-function-name (prefix insert)
+  (if (vectorp prefix) (setq prefix (aref prefix 0)))
+  (if (symbolp prefix) (setq prefix (remove-blanks (symbol-name prefix))))
+  (if (symbolp insert) (setq insert (remove-blanks (symbol-name insert))))
+  (let ((name (mk-symbol prefix insert)))
+    (if (fboundp name)
+	(make-function-name "%s-1" name)
+	name)))
+
+;; ----------------------------------------------------------------------
+;; `Interactive' Read Functions
+
+(defun read-number-with-default ()
+  (let* (this-event
+	 (x (read-string (format "Event name (default: %d)"
+				 (setq this-event (number-at-cursor))))))
+    (if (string-equal x "")
+	(if (numberp this-event) this-event (error "Not a number"))
+	(number-to-string x))))
+
+(defun read-symbol-with-default () 
+  (let* (this-event
+	 (x (read-string (format "Event name (default: %s)"
+		       (setq this-event (symbol-at-cursor))))))
+    (if (string-equal x "")
+	this-event
+	x)))
+
+(defun number-at-cursor ()
+  (save-excursion
+    (if (looking-at "[ \t\.(]+")
+	(goto-char (match-end 0))
+	(progn (re-search-backward "[^0-9]" nil t) (forward-char 1)))
+    (let ((start (point))
+	  max
+	  end)
+      (setq max (save-excursion (end-of-line) (point)))
+      (if (looking-at "[-0-9]+")
+	  (if (re-search-forward "[ ()\.\n\t]" max t)
+	      (string-to-number (buffer-substring start (- (point) 1)))
+	      (string-to-number (buffer-substring start max)))))))
+
+(defun symbol-at-cursor ()
+  (save-excursion
+    (if (looking-at "[ \t\.(]+")
+	(goto-char (match-end 0))
+	(progn (re-search-backward "[ \t\.()\n]+" nil t) (forward-char 1)))
+    (let ((start (point))
+	  max
+	  end)
+      (setq max (save-excursion (end-of-line) (point)))
+      (if (re-search-forward "[ ()\.\n\t]" max t)
+	  (buffer-substring start (- (point) 1))
+	  (buffer-substring start max)))))
+
+(defun define-mode-keys (mode-map-name mode-map keys)
+  ;; An entry in keys may have two forms:
+  ;; (key function)     
+  ;; (keymap key function)
+  ;; The second allows you to create subkeymaps, e.g. Control-Z
+  (if (should-i-install mode-map-name 'keys)
+      (mapcar
+       (function (lambda (x)
+		   (if (equal (length x) 2)
+		       (define-key mode-map (car x) (car (cdr x)))
+		       (if (keymapp (eval (car x)))
+			   (define-key (eval (car x)) (car (cdr x)) (car (cdr (cdr x))))
+			   (error
+			    (format "Keymap %s not defined in mode %s" (car x) (car mode-map)))))))
+       keys)))
+
+;; HOOKS
+
+;; All of the necessary hooks are set up by doing
+;; (mode-interface-hook "mode").  E.g. (mode-interface-hook "acl2")
+
+(defun extend-hook (hook entry)
+  ;; Add an entry onto a mode-hook, being sensitive to the
+  ;; stupid Emacs permission for it to be a function or list
+  ;; of functions.
+  (cond ((null hook) (list entry))
+	((symbolp hook) (if (not (equal entry hook)) (list hook entry) hook))
+	((not (consp hook)) 
+	 (message (format "Strange hook, %s, replaced by %s." hook entry))
+	 (list entry))
+	((equal (car hook) 'lambda)
+	 (list hook entry))
+	((member-equal entry hook) hook)
+	(t (append hook (list entry)))))
+
+(defmacro define-interface (xxx mode-map-name menu-bar menu-bar-remove popup-menu keys)
+  ;; xxx = mode-name, because emacs has some inhibitions about setting mode-name.
+  (let ((<mode>-map-set (make-function-name xxx "-map-set"))
+	(<mode>-mode-revert-fn (make-function-name xxx "-revert-fn"))
+	(<mode>-saved-mode-map (make-function-name xxx "-saved-map"))
+	(<mode>-menu-bar-name (make-function-name xxx "-menu-bar"))
+	(<mode>-menu-bar-remove-name (make-function-name xxx "-menu-bar-remove"))
+	(<mode>-popup-menu-name (make-function-name xxx "-popup-menu"))
+	(<mode>-keys-name (make-function-name xxx "-keys"))
+	(<mode>-mode-hook (make-function-name xxx "-hook"))
+	(<mode>-interface-hook-fn (make-function-name xxx "-interface-hook-fn"))
+	(<mode>-prefix-menu (concat (symbol-name xxx) "-menu-"))
+	(<mode>-prefix-popup (concat (symbol-name xxx) "-popup-"))
+	(<mode>-prefix-keys (concat (symbol-name xxx) "-keys-")))
+    (if (equal <mode>-popup-menu-name popup-menu)
+	(setq <mode>-popup-menu-name (make-function-name <mode>-popup-menu-name "-2")))
+    (acl2-substitute (list (cons '<mode>-map-name   mode-map-name)
+			   (cons '<mode>-menu-bar   menu-bar)
+			   (cons '<mode>-menu-bar-remove menu-bar-remove)
+			   (cons '<mode>-popup-menu popup-menu)
+			   (cons '<mode>-keys       keys)
+			   (cons '<mode>-menu-bar-name <mode>-menu-bar-name)
+			   (cons '<mode>-popup-menu-name <mode>-popup-menu-name)
+			   (cons '<mode>-menu-bar-remove-name <mode>-menu-bar-remove-name)
+			   (cons '<mode>-keys-name <mode>-keys-name)
+			   (cons '<mode>-map-set <mode>-map-set)
+			   (cons '<mode>-mode-revert-fn <mode>-mode-revert-fn)
+			   (cons '<mode>-saved-mode-map <mode>-saved-mode-map)
+			   (cons '<mode>-mode-hook <mode>-mode-hook)
+			   (cons '<mode>-interface-hook-fn <mode>-interface-hook-fn)
+			   (cons '<mode>-prefix-menu <mode>-prefix-menu)
+			   (cons '<mode>-prefix-popup <mode>-prefix-popup)
+			   (cons '<mode>-prefix-keys <mode>-prefix-keys))
+	'(progn
+
+	   (defconst <mode>-map-set nil)
+
+	   (defconst <mode>-menu-bar-name <mode>-menu-bar)
+	   (defconst <mode>-menu-bar-remove-name <mode>-menu-bar-remove)
+
+	   (defun <mode>-mode-revert-fn ()
+	     (setq <mode>-map-name <mode>-saved-mode-map)
+	     (setq <mode>-map-set nil))
+
+	   (defun <mode>-interface-hook-fn ()
+	     (cond ((and (boundp '<mode>-map-name) (not <mode>-map-set))
+		    (setq <mode>-saved-mode-map (copy-keymap <mode>-map-name))
+		    (remove-from-menu-bar <mode>-menu-bar-remove <mode>-map-name)
+		    (extend-menu-bar '<mode>-map-name [menu-bar] <mode>-menu-bar-name
+				     <mode>-prefix-menu)
+		    (define-popup-menu '<mode>-map-name '<mode>-popup-menu-name 
+		                       <mode>-popup-menu)
+		    (define-mode-keys '<mode>-map-name <mode>-map-name <mode>-keys)
+		    (setq <mode>-map-set t))))
+
+	   (defconst <mode>-mode-hook
+	     (if (boundp '<mode>-mode-hook)
+		 (extend-hook <mode>-mode-hook '<mode>-interface-hook-fn)
+		 '(<mode>-interface-hook-fn)))
+
+	   (<mode>-interface-hook-fn)))))
+
+;; Debugging
+;; (defun set-last-click (click) (setq last-click click))
+;; (define-menu-item mks-menu "Set last click" 'set-last-click 'click)
+;; (x-popup-menu last-click inferior-acl2-mode-popup-menu)
--- /dev/null
+++ acl2-6.0/interface/emacs/mfm-acl2.el
@@ -0,0 +1,675 @@
+;; May, 1994
+;; Matt Kaufmann and Mike Smith
+
+(require 'mfm)
+
+;; Possible future extensions:
+
+; Arrange that stop-proof-tree sends an appropriate string to the ACL2
+; process, with both #+acl2-loop-only and #-acl2-loop-only in it, so
+; that the proof-tree output is inhibited in ACL2 whether we're in a
+; break or not.  Similarly for start-proof-tree.  If that sort of thing
+; works, consider options for suspend-proof-tree and resume-proof-tree
+; that interrupt and resume an ACL2 proof.
+
+; We need to be able to distinguish GNU emacs 19 and its descendents from
+; 18 and lemacs and ...
+; Fortunately, mfm.el already provides this test by setting 
+; mfm-emacs-version to the version number if it can figure it out.
+
+; From mfm.el, we need to re-assign this value:
+(defconst *mfm-secondary-buffer-name-alist* '(("prooftree" ?0)))
+
+(defconst *acl2-proof-tree-height-default* 17)
+(defconst *checkpoint-recenter-line-default* 3)
+; The following are set by start-proof-tree.
+(defvar *acl2-proof-tree-height* *acl2-proof-tree-height-default*)
+(defvar *checkpoint-recenter-line* *checkpoint-recenter-line-default*)
+
+(defvar *proof-tree-start-string* "\n<< Starting proof tree logging >>"
+  "Must match the corresponding ACL2 string; do not change this!")
+
+(defvar *last-acl2-point-max* nil)
+
+; The last process saved when mfm-output-filter was installed:
+(defvar *saved-acl2-process-filter*)
+
+; *prooftree-marker* is a marker into the prooftree buffer, or nil.  It need
+; not have any meaningful position; such position would be stored in
+; overlay-arrow-position.  The only reason we have *prooftree-marker* is to
+; avoid the need to keep creating new markers.
+(defvar *prooftree-marker* nil)
+
+; *** MOVED TO acl2-interface.
+;(defvar ctl-z-keymap (make-sparse-keymap))
+;(defvar old-ctl-z-key (key-binding "\C-Z"))
+
+; The following is an emacs variable that we appropriate.
+(setq overlay-arrow-string ">")
+
+(defun save-last-acl2-point-max (string)
+  (if (and *mfm-secondary-buffer*
+           (equal (buffer-name *mfm-secondary-buffer*) "prooftree"))
+      (setq *last-acl2-point-max*
+            (save-excursion
+              (set-buffer *mfm-buffer*)
+              (point-max)))))
+
+(defun clear-overlay-from-prooftree-buffer (string)
+  (if (not (mfm-paused-p "prooftree"))
+      (setq overlay-arrow-position nil)))
+
+(defmacro message-beep (&rest args)
+  (list 'progn
+        '(beep)
+        (cons 'message args)))
+
+(defun initialize-proof-tree-windows (do-init)
+  (or (and (not do-init)
+           *acl2-proof-tree-height*)
+      (setq *acl2-proof-tree-height*
+            (if (numberp *acl2-proof-tree-height*)
+                (read-from-minibuffer
+                 (format "Height of proof tree window (currently %d): "
+                         *acl2-proof-tree-height*)
+                 (format "%d" *acl2-proof-tree-height*)
+                 nil t)
+              (read-from-minibuffer
+               (format "Height of proof tree window (default %d):"
+                       *acl2-proof-tree-height-default*)
+               (format "%d" *acl2-proof-tree-height-default*)
+               nil t)))))
+
+(defun initialize-acl2-buffer-process (do-init)
+  ;; returns non-nil upon success, nil upon failure
+  (let* ((proc-try (and (not do-init)
+                        *mfm-buffer*
+                        (get-buffer-process *mfm-buffer*)))
+         (proc
+          (or proc-try
+              (and
+               (setq *mfm-buffer*
+                     (if (stringp *mfm-buffer*)
+
+; Keep the following in sync with stop-proof-tree
+
+                         (let ((proc (get-buffer-process *mfm-buffer*)))
+                           (if (and proc
+                                    (boundp '*saved-acl2-process-filter*))
+                               ;;so, we've done at least one save
+                               (set-process-filter proc *saved-acl2-process-filter*))
+                           (read-from-minibuffer
+                            (format "ACL2 buffer (currently %s): "
+                                    *mfm-buffer*)
+                            *mfm-buffer* nil))
+                       (read-from-minibuffer "ACL2 buffer: " "*shell*" nil)))
+               (get-buffer-process *mfm-buffer*)))))
+    (and proc
+         (let ((fltr (process-filter proc)))
+           (if (not (eq fltr 'mfm-output-filter))
+               (progn (setq *saved-acl2-process-filter* fltr)
+                      (set-process-filter proc 'mfm-output-filter)))
+           (if (not (memq 'save-last-acl2-point-max
+                          *mfm-secondary-filter-functions*))
+               (setq *mfm-secondary-filter-functions*
+                     (cons 'save-last-acl2-point-max
+                           *mfm-secondary-filter-functions*)))
+           (if (not (memq 'clear-overlay-from-prooftree-buffer
+                          *mfm-secondary-filter-functions*))
+               (setq *mfm-secondary-filter-functions*
+                     (cons 'clear-overlay-from-prooftree-buffer
+                           *mfm-secondary-filter-functions*)))
+           (mfm-set-keymap-interrupt)
+           t))))
+
+(defun initialize-checkpoint-recenter-line (do-init)
+  (or (and (not do-init)
+           *checkpoint-recenter-line*)
+      (setq *checkpoint-recenter-line*
+            (if (numberp *checkpoint-recenter-line*)
+                (read-from-minibuffer
+                 (format "Line for top of checkpoint display (currently %d): "
+                         *checkpoint-recenter-line*)
+                 (format "%d" *checkpoint-recenter-line*)
+                 nil t)
+              (read-from-minibuffer
+               (format "Line for top of checkpoint display (default %d): "
+                       *checkpoint-recenter-line-default*)
+               (format "%d" *checkpoint-recenter-line-default*)
+               nil t)))))
+
+;; CHECKPOINT-HELP assumes these keys have been bound.
+;; So we defvar it here.
+(defvar prooftree-subkey "\C-Z")
+
+(defun checkpoint-help ()
+  "Provides information about proof-tree/checkpoint tool.
+Use `C-h d' to get more detailed information for specific functions."
+  (interactive)
+  ;; Here is how to do it in emacs 19:
+  ;; (describe-bindings "\C-Z")
+  ;; But in emacs 18, describe-bindings doesn't take an arg, so:
+  (with-output-to-temp-buffer "*Help*"
+    (princ "Checkpoint help.  
+Use `C-h d' to get information on specific functions.
+
+default key(s)  binding
+--------------  -------
+
+C-z ?, C-z h    checkpoint-help
+C-z g           goto-subgoal
+C-z r           resume-proof-tree
+C-z s           suspend-proof-tree
+C-z c           checkpoint
+C-z o           select-other-frame-with-focus
+C-z b           visit-proof-tree
+C-z B           visit-proof-tree-other-frame
+C-z z           [old C-z; suspends emacs or iconifies frame]
+")))
+
+;; *** INITIALIZE-PROOF-TREE-KEYS handled by acl2-interface.el
+;; Actually, the DEFINE-INTERFACE macro sets up the mode hook for
+;; prooftree mode.
+
+;;; The following code sets up the prooftree in prooftree mode, which is just
+;;; Fundamental mode.  But this allows us to use the prooftree-mode-map and
+;;; prooftree-mode-hook to set up menu and moused based interactions in a
+;;; principled fashion.
+
+(defvar prooftree-mode-map (make-keymap))
+
+(defvar prooftree-mode-hook '()
+  "*Hook for customizing inferior prooftree mode.")
+
+;;; Example: (define-key prooftree-mode-map "\C-Q" 'foo)
+
+(defun prooftree-mode () 
+  "Major mode for interacting with prooftree buffers.
+
+\\{prooftree-mode-map}
+
+Customization:  Entry to this mode runs the hooks on `prooftree-mode-hook'.
+"
+  (interactive)
+  (setq major-mode 'prooftree-mode)
+  (setq mode-name "Prooftree")
+  (use-local-map prooftree-mode-map)
+  (run-hooks 'prooftree-mode-hook))
+
+;;; end of prooftree-mode.
+
+(defun start-proof-tree-setup ()
+  (delete-other-windows)
+  (switch-to-buffer *mfm-buffer*)
+  (split-window-vertically *acl2-proof-tree-height*)
+  (switch-to-buffer "prooftree")
+  (prooftree-mode)
+  (other-window 1))
+
+(defun start-proof-tree (do-init)
+
+  "Start the ACL2 proof tree display.  With an argument, queries for values of
+user-settable parameters.  This also queries for the ACL2 buffer the first time
+it is called."
+
+  (interactive "P")
+  (initialize-proof-tree-windows do-init)
+  (initialize-checkpoint-recenter-line do-init)
+  (if (initialize-acl2-buffer-process do-init)
+      (progn (setq *mfm-secondary-buffer* nil)
+             (mfm-initialize-secondary-buffer-alist)
+             (start-proof-tree-setup))
+      (error "No process; start shell or inferior-acl2 and start-proof-tree again."))
+
+; Handled by acl2-interface.el:
+; (if (not (equal ctl-z-keymap (key-binding "\C-Z")))
+;     (initialize-proof-tree-keys do-init))
+  )
+
+(defun start-proof-tree-noninteractive (mfm-buffer)
+
+  "A typical call of this function is:
+
+  (start-proof-tree-noninteractive \"*shell*\")
+
+You may find it useful to put the above form followed by some version of the
+following forms in your .emacs file, assuming that you have loaded ACL2 file
+emacs/emacs-acl2.el.  The result should be the start of a new frame (perhaps
+after you click in the initial emacs window) to the side of the first frame,
+with the \"prooftree\" buffer displayed in the new frame.
+
+  (cond ((and (eq window-system 'x)
+              (fboundp 'x-display-pixel-width)
+              (= (x-display-pixel-width) 2048) ; for a wide monitor
+              )
+         (delete-other-windows)
+         (if (boundp 'emacs-startup-hook) ; false in xemacs
+             (push 'new-prooftree-frame emacs-startup-hook))))"
+
+; Typical call:
+; 
+  (setq *mfm-buffer* mfm-buffer)
+  (start-proof-tree nil))
+
+(defun stop-proof-tree ()
+
+  "Stop the ACL2 proof tree display, and delete all windows except for one,
+which will contain the ACL2 buffer, emacs variable *mfm-buffer*.  See also
+suspend-proof-tree."
+
+  (interactive)
+  (let ((proc (get-buffer-process *mfm-buffer*)))
+    (if (not proc)
+        (message-beep "No process for ACL2 buffer (emacs variable *mfm-buffer*), %s."
+		      *mfm-buffer*)
+      (if (boundp '*saved-acl2-process-filter*) ;so, we've done at least one save
+          (set-process-filter proc *saved-acl2-process-filter*))
+      (delete-other-windows)
+      (switch-to-buffer *mfm-buffer*))))
+
+(defun suspend-proof-tree (&optional suppress-message)
+  ;; Returns non-nil if and only if anything happens.
+
+  "Freeze the contents of the \"prooftree\" buffer, until
+resume-proof-tree is invoked.  Unlike stop-proof-tree, the only effect
+of suspend-proof-tree is to stop putting characters into the
+\"prooftree\" buffer; in particular, strings destined for that buffer
+continue NOT to be put into the primary buffer, which is the value of
+the emacs variable *mfm-buffer*."
+
+  (interactive)
+  (if (not (mfm-paused-p "prooftree"))
+      (progn (setq *mfm-paused-buffers*
+                   (cons "prooftree" *mfm-paused-buffers*))
+             (or suppress-message
+                 (message "suspending prooftree"))
+             t)
+    (or suppress-message
+        (message-beep "prooftree is already suspended"))
+    nil))
+
+(defun remove1-equal-rec (elt lst)
+  (if (null lst)
+      lst
+    (if (equal elt (car lst))
+        (cdr lst)
+      (cons (car lst) (remove1-equal-rec elt (cdr lst))))))
+
+(defun remove1-equal (elt lst)
+  (if (member-equal elt lst)
+      (remove1-equal-rec elt lst)
+    lst))
+
+(defun visit-proof-tree ()
+  "Switch to the proof tree buffer in another window unless there is only one
+window, in which case swtich in the current window."
+  (interactive)
+  (if (< 1 (count-windows))
+      (other-window 1))
+  (switch-to-buffer "prooftree"))
+
+(defun resume-proof-tree (&optional not-eob-p suppress-message)
+; Returns non-nil if and only if anything happens.
+
+  "Resume original proof tree display, re-creating buffer
+\"prooftree\" if necessary.  See also suspend-proof-tree.  With prefix
+argument:  push the mark, do not modify the windows, and move point to
+end of *mfm-buffer*."
+
+  (interactive "P")
+  (if (not (get-buffer "prooftree"))
+      (mfm-create-buffers-from-secondary-buffer-name-alist))
+  (if (not not-eob-p)
+      (progn (push-mark (point) nil)
+             (goto-char (point-max))
+             (start-proof-tree-setup)))
+  (if (mfm-paused-p "prooftree")
+      (progn
+        (setq *mfm-paused-buffers*
+              (remove1-equal "prooftree" *mfm-paused-buffers*))
+        (or suppress-message
+            (if not-eob-p
+                (message "resuming prooftree")
+              (message "mark set; resuming prooftree")))
+        t)
+    (or suppress-message
+        (if not-eob-p
+            (message "prooftree not currently suspended")
+          (message "mark set; prooftree not currently suspended")))
+    nil))
+
+(defun search-backward-point (string &optional bound no-error repeat-count)
+  ;; Same as search-backward in emacs 19, but not in emacs 18 -- except,
+  ;; saves excursion.
+  (save-excursion
+    (search-backward string bound no-error repeat-count)
+    (point)))
+
+(defun position-of-checkpoint (checkpoint-string)
+  (save-excursion
+    (let* ((case-fold-search nil)
+           (bound (search-backward-point *proof-tree-start-string* nil t)))
+      (if bound
+          ;; We treat "*3.4" much differently from "Subgoal 4" or "Goal''".
+          ;; The assumption is that the first occurrence of such a string,
+          ;; without the trailing slash, is when the goal is pushed; the second
+          ;; occurrence is therefor what we want.
+          (if (equal (aref checkpoint-string 0) ?*)
+              (progn
+                (goto-char bound)
+                (if (re-search-forward
+                     (format "%s[.]?[^./0-9]" checkpoint-string)
+                     nil t 2)
+                    (let ((saved-point (match-beginning 0)))
+                      ;; make sure we're still in the same proof!
+                      (and (equal (search-backward-point
+                                   *proof-tree-start-string* nil t)
+                                  bound)
+                           (progn (goto-char saved-point)
+                                  (beginning-of-line)
+                                  (point))))))
+            (if (search-backward (format "\n%s\n" checkpoint-string) bound t)
+                (progn (forward-line 1)
+                       (point))
+              (and (equal checkpoint-string "Goal")
+                   bound)))))))
+
+(defun checkpoint-on-line ()
+  (let ((bound (save-excursion
+                 (end-of-line)
+                 (point)))
+	(case-fold-search nil))
+    (save-excursion
+      (beginning-of-line)
+      ;; Pretty fancy stuff -- we take special care to let double-quote (")
+      ;; terminate the goal name, since goal names sometimes appear in
+      ;; double-quotes (as in hints).  Note that we are happy to have regular
+      ;; expressions that match too much, as long as we find it rare that they
+      ;; do so.
+      (if (or (re-search-forward
+               "\\(\\[[^\n]+\\]\\)?Goal[^ \n\",]*\\(,\\| \\|$\\|\"\\)"
+               bound t)
+              (re-search-forward
+               "\\(\\[[^\n]+\\]\\)?Subgoal [^ \n\",]*\\(,\\| \\|$\\|\"\\)"
+               bound t)
+              (re-search-forward
+               "[*][1-9][0-9]*\\([.][0-9]+\\)*"
+               bound t))
+          (let* ((beg (match-beginning 0))
+                 (end (match-end 0))
+                 (last-char (char-after (1- end))))
+            (buffer-substring beg
+                              (if (memq last-char '(?\n ?\ ?\" ?\,))
+                                  (1- end)
+                                end)))))))
+
+(defun checkpoint-from-prooftree-buffer-1 (arg)
+  ;; assumes that we're in the exposed prooftree buffer if there is one
+  (if (equal arg 0)
+      (progn (set-buffer "prooftree")
+             (beginning-of-buffer)))
+  (prog1 (or (progn (beginning-of-line)
+                    (and (looking-at "c")
+                         (checkpoint-on-line)))
+             (if (search-forward "\nc" nil t)
+                 (checkpoint-on-line)
+               (goto-char (point-min))
+               (and (search-forward "\nc" nil t)
+                    (checkpoint-on-line))))
+    (forward-line)))
+
+(defun checkpoint-from-prooftree-buffer (buff arg)
+  ;; As a side effect, advances one line past the checkpoint found (or, stays
+  ;; at the bottom).
+  (let ((obuff (current-buffer)))
+    (if buff
+        (if (equal (buffer-name obuff) "prooftree")
+            (checkpoint-from-prooftree-buffer-1 arg)
+          (let ((w (get-buffer-window buff)))
+            (if w
+                (let ((old-w (get-buffer-window obuff)))
+                  (select-window w)
+                  (prog1
+                      (checkpoint-from-prooftree-buffer-1 arg)
+                    (select-window old-w)))
+              (progn
+                ;; This is the only way I've found to move the point.
+                (switch-to-buffer buff)
+                (prog1
+                    (checkpoint-from-prooftree-buffer-1 arg)
+                  (switch-to-buffer obuff))))))
+      (message-beep "Buffer prooftree not found.")
+      nil)))
+
+(defun goto-subgoal-message (new-point saved-point-max)
+  (if (or (= new-point saved-point-max)
+          (not (save-excursion
+                 (forward-line 2) ;in case we're looking at "Goal"
+                 (search-forward *proof-tree-start-string* nil t))))
+      (message "Point pushed;  Moved to goal in final proof in ACL2 buffer.")
+    (message "Point pushed;  Moved to goal in already completed proof.")))
+
+(defun ping-buffer ()
+  (insert " ")
+  (backward-delete-char 1))
+
+(defun update-prooftree-overlay ()
+  ;; Be sure to redisplay after calling this function, or else the overlay may
+  ;; not appear.
+  (save-excursion
+    (if (not (and (markerp *prooftree-marker*)
+		  (marker-buffer *prooftree-marker*)))
+	(setq *prooftree-marker* (make-marker)))
+    (set-buffer "prooftree")
+    (save-excursion
+      (forward-line -1)
+      (setq overlay-arrow-position
+            (let ((overlay-point
+                   (let ((point (point)))
+                     (if (equal point (point-min))
+                         nil
+                       point))))
+              (if overlay-point
+                  (set-marker *prooftree-marker*
+                              overlay-point
+                              (get-buffer "prooftree"))
+                nil)))
+      (ping-buffer))))
+
+(defun switch-to-mfm-buffer ()
+  (let ((w (get-buffer-window *mfm-buffer* t)))
+    (cond ((window-live-p w)
+	   (select-window w)
+	   (let ((focus-follows-mouse nil))
+	     (select-frame-set-input-focus (window-frame w))))
+	  (t
+	   (if (let ((current-frame
+		      (window-frame (get-buffer-window (current-buffer)))))
+		 (and current-frame
+		      (equal (frame-parameter current-frame 'name)
+			     "prooftree-frame")))
+	       (select-other-frame-with-focus))
+	   (switch-to-buffer *mfm-buffer*)))))
+
+(defun goto-subgoal (checkpoint-string &optional bound)
+
+  "Go to the specified subgoal in the ACL2 buffer (emacs variable *mfm-buffer*)
+that lies closest to the end of that buffer -- except if the current buffer is
+\"prooftree\" when this command is invoked, the subgoal is the one from the
+proof whose tree is displayed in that buffer.  A default is obtained, when
+possible, from the current line of the current buffer.
+
+If there is more than one frame and *mfm-buffer* is displayed in some frame,
+then that frame is made the frame with the cursor, where the the specified goal
+is shown.  Otherwise, if the current frame is named \"prooftree-frame\" then we
+move to another frame to display the goal in *mfm-buffer*."
+
+  (interactive
+   (list (read-from-minibuffer "Goal name: " (checkpoint-on-line))))
+  (let ((bound-supplied-p bound)
+	(bound (or bound
+		   (and (equal (buffer-name (current-buffer)) "prooftree")
+			*last-acl2-point-max*)))
+	saved-point-max)
+    (let ((new-point
+	   (save-excursion
+	     (set-buffer *mfm-buffer*)
+	     (setq saved-point-max (point-max))
+	     (goto-char (if bound (min (+ 100 bound) saved-point-max) saved-point-max))
+	     (and checkpoint-string
+		  (position-of-checkpoint checkpoint-string)))))
+      (if new-point
+	  (progn
+	    (switch-to-mfm-buffer)
+	    (push-mark (point))
+	    (goto-char new-point)
+	    (recenter *checkpoint-recenter-line*)
+	    (if bound-supplied-p
+		(update-prooftree-overlay)
+	      (setq overlay-arrow-position nil))
+	    (goto-subgoal-message new-point saved-point-max))
+	(message-beep
+	 (format "Cannot find goal named \"%s\"." checkpoint-string))))))
+
+(defun checkpoint (keep-suspended-p)
+
+  "Go to a checkpoint, as displayed in the \"prooftree\" buffer with
+the character \"c\" in the first column.  With non-zero prefix
+argument:  move the point in the ACL2 buffer (emacs variable
+*mfm-buffer*) to the first checkpoint displayed in the \"prooftree\"
+buffer, suspend the proof tree (see suspend-proof-tree), and move the
+cursor below that checkpoint in the \"prooftree\" buffer.  Without a
+prefix argument, go to the first checkpoint named below the point in
+the \"prooftree\" buffer (or if there is none, to the first
+checkpoint).  Note however that unless the proof tree is suspended or
+the ACL2 proof is complete or interrupted, the cursor will be
+generally be at the bottom of the \"prooftree\" buffer each time it is
+modified, which causes the first checkpoint to be the one that is
+found.
+
+If the prefix argument is 0, move to the first checkpoint but do not
+keep suspended."
+
+  (interactive "P")
+  (let ((suspended-p (suspend-proof-tree t))
+        (buff (get-buffer "prooftree")))
+    (if *mfm-buffer*
+        (let ((checkpoint-name (and buff
+                                    (checkpoint-from-prooftree-buffer
+				     buff keep-suspended-p))))
+          (if checkpoint-name
+              (goto-subgoal checkpoint-name *last-acl2-point-max*)
+            (message-beep "Cannot find a checkpointed goal."))
+          (if (and (not keep-suspended-p)
+                   suspended-p)
+              (resume-proof-tree t t)))
+      (if (and (not keep-suspended-p)
+               suspended-p)
+          (resume-proof-tree t t))
+      (message-beep "There is no active ACL2 buffer"))))
+
+(if (not (fboundp 'select-frame-set-input-focus)) ; xemacs
+    (defun select-frame-set-input-focus (frame)
+      (focus-frame frame)))
+
+(defun select-other-frame-with-focus ()
+  "Switch to another frame (which is created if necessary), and make it the one
+that contains the cursor."
+  (interactive)
+  (let ((other-frame (get-other-frame))
+	;; So that select-frame-set-input-focus calls x-focus-frame:
+        (focus-follows-mouse nil))
+    (select-frame-set-input-focus other-frame)))
+
+(if (not (fboundp 'frame-parameter)) ; xemacs
+    (defun frame-parameter (frame sym)
+      (frame-property frame sym)))
+
+(defun my-select-frame-by-name (frame-name)
+
+;;; Like select-frame-by-name but without causing an error.
+
+  (let ((x (frame-list))
+	ans)
+    (while x
+      (cond ((equal (frame-parameter (car x) 'name)
+		    frame-name)
+	     (setq ans (car x))
+	     (setq x nil)))
+      (setq x (cdr x)))
+    ans))
+
+(defun prooftree-remaining-frame-width ()
+  (let* ((frame-pixel-width (frame-pixel-width))
+	 (full-pixel-width
+	  (if (fboundp 'display-pixel-width) ; not xemacs
+	      (display-pixel-width)
+	    (x-display-pixel-width)))
+	 (pixel-width-of-new-frame
+	  (and full-pixel-width
+	       (- full-pixel-width
+		  (+ (frame-parameter nil 'left) frame-pixel-width)))))
+    (and full-pixel-width
+	 (/ (* (frame-width) pixel-width-of-new-frame)
+	    frame-pixel-width))))
+
+(defun new-prooftree-frame (&optional doit)
+  (interactive "P")
+  (cond
+   ((and (not doit)
+	 (my-select-frame-by-name "prooftree-frame"))
+    (beep)
+    (message "There is already a frame named prooftree-frame.
+Give an argument if you want to create a new frame nonetheless.")
+    nil)
+   (t
+    (let ((new-width (prooftree-remaining-frame-width))
+	  (min-width 40)
+	  (focus-follows-mouse nil)
+	  (old-frame (window-frame (get-buffer-window (current-buffer)))))
+      (cond
+       ((null new-width)
+	(error "Unable to compute available width for new frame."))
+       ((or doit (<= min-width new-width)) ; else don't bother
+	(let ((new-frame
+	       (new-frame (list (cons 'name "prooftree-frame")
+				(cons 'width
+				      (max min-width new-width))
+				(cons 'height (frame-height))
+				(cons 'top (frame-parameter nil 'top))
+				(cons 'left (+ (frame-parameter nil 'left)
+					       (frame-pixel-width)
+					       (or (get 'border-width
+							'x-frame-parameter)
+						   ;; nil in xemacs
+						   5)))))))
+
+; We have seen an "X protocol error" that crashes Emacs while running VNC on a
+; Mac.  The following ad hoc 20-millisecond sleep seems to solve the problem,
+; but we welcome suggestions from Emacs gurus for a better approach.
+
+          (sleep-for 0 20)
+	  (select-frame-set-input-focus new-frame)
+	  (switch-to-buffer "prooftree")
+	  (message "Columns in new frame: %d" (frame-width new-frame))
+	  new-frame))
+       (t
+	(error "Not enough columns available (have %d, need %d); can solve with prefix arg"
+	       new-width
+	       min-width)))))))
+
+(defun visit-proof-tree-other-frame (&optional doit)
+  "Switch to prooftree buffer in \"prooftree-frame\" frame (which is created if
+necessary).  Use meta-x select-other-frame-with-focus to switch back to
+original frame."
+  (interactive "P")
+  (let ((old-frame (my-select-frame-by-name "prooftree-frame")))
+    (cond
+     (old-frame
+      (let ((focus-follows-mouse nil))
+	(select-frame-set-input-focus old-frame))
+      (switch-to-buffer "prooftree"))
+     (t (let ((frame (new-prooftree-frame doit)))
+	  (select-frame-set-input-focus frame))))))
+
+(provide 'mfm-acl2)
--- /dev/null
+++ acl2-6.0/interface/emacs/README-mouse.mss
@@ -0,0 +1,506 @@
+@make(clinote)
+ @device(postscript)
+ @style(indent 0, font clitimesroman, spacing 1, spread 1 line)
+@begin(comment)
+ @device(file)
+ @style(indent 0, justification no, leftmargin 0, rightmargin 0 in, spacing 1, spread 1 line)
+@end(comment)
+
+@define(menu=format,leftmargin +.25in, afterentry {@tabset(2inch,2.5inch,3inch,3.5inch,4inch,4.5inch)})
+
+@comment{ STILL DEPENDS ON DIRECTORY.  FIX WHEN INSTALLED.
+
+   "/slocal/src/acl2/v1-8/interface/emacs/"
+
+}
+
+@title(The ACL2 Prooftree and Mouse Interface)
+@author(M. Kaufmann & M. K. Smith)
+
+@section(Introduction)
+
+NOTE:  This interface should be considered preliminary, although it has been
+used successfully at Computational Logic, Inc.  It is not part of the ACL2
+software in the strictest sense (which is co-authored by Matt Kaufmann and J
+Moore), but we feel that it will be useful to ACL2 users.
+
+This note describes how to get the ACL2/Emacs prooftree and mouse
+support.  You just need to add a single autoload form to your .emacs
+file.  And then issue the correspoding M-x command.
+
+The prooftree support has been tested in the following Emacs:
+@begin(format)
+ Emacs 18
+ Emacs 19        - with comint and WFS's shell, sshell.el.
+ Lemacs 19
+@end(format)
+
+The menu and mouse support currently works with Emacs 19.  
+
+@b[If you don't want to deal with any of this:]  You probably want to
+put the following form in your acl2-customization.lisp file.
+@begin(verbatim)
+
+ :STOP-PROOF-TREE
+
+@end(verbatim)
+This will turn off the proof tree printing from ACL2.  For documentation in ACL2 do 
+@begin(verbatim)
+ :doc proof-tree
+@end(verbatim)
+To turn proof trees back on use `:START-PROOF-TREE'.@*
+NOTE: If you do `:STOP-PROOF-TREE' in ACL2, then M-x start-proof-tree
+will not accomplish anything useful in Emacs.
+
+
+@section(LOADING EMACS INTERFACE CODE)
+
+@subsection(Simplest .emacs Additions)
+
+If you want the full interface, put the following in your  .emacs
+file after replacing /slocal/src/acl2/v1-8/ with the full pathname
+of your acl2-sources/ directory.
+@begin(verbatim)
+
+ (setq *acl2-interface-dir*
+   "/slocal/src/acl2/v1-8/interface/emacs/")
+
+ (autoload 'run-acl2 ;;@i[emacs 19.27 only at this time]
+   (concat *acl2-interface-dir* "top-start-inferior-acl2")
+   "Begin ACL2 in an inferior ACL2 mode buffer." 
+   t)
+
+@end(verbatim)
+Then, to get things started in Emacs do `M-x run-acl2'.  Use `M-x
+acl2-mode' to get `<acl2-file>.lisp' into the right mode.  The
+commands in the various modes are listed in a later section.  But you
+can see most of them by observing the new pull-down menus and pop-up
+menu in inferior ACL2 mode and ACL2 mode.  The pop-up menu is tied to
+mouse-3.
+
+If you just want proof trees, use the following after replacing
+/slocal/src/acl2/v1-8/ with the full pathname of your acl2-sources/
+directory.
+
+@begin(verbatim)
+
+ (setq *acl2-interface-dir*
+   "/slocal/src/acl2/v1-8/interface/emacs/")
+
+(autoload 'start-proof-tree
+  (concat *acl2-interface-dir* "top-start-shell-acl2")
+  "Enable proof tree logging in a prooftree buffer." 
+  t)
+
+@end(verbatim)
+
+@subsection(More Control from .emacs: Setting preferences)
+
+The alist, *acl2-user-map-interface*, determines what menus you get.  
+If a feature is included after a mode name, then you get it.
+@begin(verbatim)
+
+(defvar *acl2-user-map-interface*
+  '((inferior-acl2-mode menu-bar popup-menu keys)
+    (acl2-mode          menu-bar popup-menu keys)
+    (prooftree-mode     menu-bar popup-menu keys)))
+
+@end(verbatim)
+
+If you set the following to T, you will switch to the inferior ACL2
+buffer when you send forms, regions, or buffers to it.
+@begin(verbatim)
+
+ (setq *acl2-eval-and-go* nil)
+
+@end(verbatim)
+If you set the following to NIL you will be queried for their values
+when you start up a prooftree buffer (via M-x start-proof-tree).
+These are the defaults you get based on the autoload above.
+@begin(verbatim)
+
+ (setq *acl2-proof-tree-height* 17)
+ (setq *checkpoint-recenter-line* 3)
+
+@end(verbatim)
+
+
+@section(Commands)
+
+Commands are enabled based on the value of the alist,
+*acl2-user-map-interface*, as described above.  There are some conventions that
+you need to know regarding arguments to mouse commands.
+
+If a menu bar entry is of the form
+@begin(format)
+   Print event ...
+@end(format)
+the "..." indicates that you will be prompted in the minibuffer for an argument.
+
+If a menu bar entry is of the form
+@begin(format)
+   Mode >
+@end(format)
+the ">" indicates a suborninate menu that will pop up if you release
+on this menu item. 
+
+Pop-up menu items indicate whether they take an argument based on a
+preceding ".".  The argument is determined by what you clicked on to
+bring up the menu.  Arguments derived from things that appear in the
+chronology are somewhat robust.  So that if you had a list of events
+on the screen like:
+@begin(verbatim)
+         13  (DEFMACRO TEXT (X) ...)
+ L       14  (DEFUN MSG-P (X) ...)
+ L       15  (DEFUN MAKE-PACKET (X Y Z) ...)
+ L       16  (DEFUN HISTORY-P (L) ...)
+         17  (DEFMACRO INFROM (X) ...)
+@end(verbatim)
+to see event 14 you could click right anywhere on that line and select
+either ". Print Event" or ". Print Command".
+
+
+@subsection(Prooftree Related)
+
+@begin(menu)
+M-x start-proof-tree
+M-x stop-proof-tree
+@end(menu)
+
+
+@subsection(Prooftree Mode)
+
+@subsubsection<POPUP MENU>
+
+@begin(menu)
+Abort              @\Abort *inferior-acl2*.
+Goto subgoal       @\Go to clicked on subgoal in *inferior-acl2*. 
+Resume proof tree  @\Resume printing proof tree.
+Suspend proof tree @\Suspend printing proof tree.
+Checkpoint/Suspend @\Suspend prooftree and go to clicked on checkpoint.
+Checkpoint         @\Go to clicked on checkpoint.
+Help               @\
+@end(menu)
+
+@subsubsection<MENU BAR>
+
+@begin(menu)
+Prooftree@begin(menu)
+ Checkpoint @\Go to next checkpoint
+ Goto subgoal @\That cursor is on.
+ Checkpoint / Suspend @\Go to next checkpoint and suspend proof tree.
+ Resume proof tree 
+ Suspend proof tree 
+ Abort @\Abort prooftree. (ACL2 will continue to send prooftrees, it just
+       @\won't go the the prooftree buffer.) 
+ Help 
+@end(menu)
+@end(menu)
+
+@subsubsection<KEYS>
+
+@begin(menu)
+C-z z @\Previous C-z key binding
+C-z c @\Go to checkpoint
+C-z s @\Suspend proof tree
+C-z r @\Resume proof tree
+C-z a @\Mfm abort secondary buffer
+C-z g @\Goto subgoal
+C-z h @\help
+C-z ? @\help
+@end(menu)
+
+
+@subsection(ACL2 Mode	)
+
+ACL2 Mode is like Lisp mode except that the functions that send sexprs
+to the inferior Lisp process expect an inferior ACL2 process in the  *inferior-acl2* buffer.
+
+@subsubsection<POPUP MENU>
+
+@begin(menu)
+Send to ACL2 @\Send top level form clicked on to ACL2.
+Add hint @\Add the hint form to the clicked on defun.
+@begin(menu)
+Do not induct.
+Do not generalize.
+Do not fertilize.
+Expand @\expand form. Requests you mouse it.
+Hands off.
+Disable@\Disable symbol. Requests you mouse it.
+Enable@\Enable symbol. Requests you mouse it.
+Induct@\Induct based on form. Requests you mouse it. 
+Cases@\Perform case split on form.Requests you mouse it. 
+@end(menu)
+Go to inferior ACL2
+Verify@\Take clicked on form into interactive prover.
+@end(menu)
+
+
+@subsubsection<KEYS>
+
+@begin(menu)
+C-x C-e @\eval last sexp
+C-c C-r @\eval region
+C-M-x   @\eval defun
+C-c C-e @\eval defun
+C-c C-z @\switch to ACL2
+C-c C-l @\load file
+C-c C-a @\show arglist
+C-c C-d @\describe symbol
+C-c C-f @\show function documentation
+C-c C-v @\show variable documentation
+C-ce    @\eval defun and go to ACL2
+C-cr    @\eval region and go to ACL2
+@end(menu)
+
+
+@subsection(Inferior ACL2 Mode)
+
+@subsubsection<MENU BAR>
+
+@begin(menu)
+Events@begin(menu)
+ Recent events @\(pbt '(:here -10))
+ Print back through ...@\(pbt <event>)
+ Undo @\(ubt ':here)
+ Oops @\(oops)
+ Undo through ... @\(ubt '<event>)
+ Undo through ... @\(ubt! '<cd>)
+      
+ Load file ... @\(cl2-load-file)
+      
+ Disable ...@\(in-theory (disable <symbol>))
+ Enable ... @\(in-theory (enable <symbol>))
+      
+ Verify guards ... @\(verify-guards '<symbol>)
+ Verify termination ... @\(verify-guards '<symbol>)
+      
+ Certify-book ... @\(certify-book <filename>)
+ Include-book ... @\(include-book <filename> )
+     
+Compound commands @begin(menu)
+ Expand compound command ... @\(puff '<cd>)
+ Expand compound command! ... @\(puff* '<cd>)
+@end(menu)
+
+Table@begin(menu)
+ Print value ... @\(table symbol)
+ Clear ... @\(table <symbol> nil nil :clear
+ Print guard ... @\(table <symbol> nil nil :guard)
+@end(menu)
+@end(menu)
+
+Print@begin(menu)
+
+ Event ... @\(pe 'event)
+ Event! ... @\(pe! 'event)
+ Back through ... @\(pbt 'event)
+
+ Command ... @\(pc '<cd>)
+ Command block ... @\(pcb '<cd>)
+ Full Command block ... @\(pcb! '<cd>)
+
+ Signature ... @\(args 'event)
+ Formula ... @\(pf 'event)
+ Properties ... @\(props 'event)
+
+ Print connected book directory @\(cbd)
+
+ Rules whose top function symbol is ... @\(pl 'event)
+ Rules stored by event ... @\(pr 'event)
+ Rules stored by command ... @\(pr! '<cd>)
+
+ Monitored-runes @\(monitored-runes)
+@end(menu)
+
+Control@begin(menu)
+
+ Load ... @\(ld filename)
+ Accumulated Persistence@begin(menu)
+  Activate @\(accumulated-persistence t)
+  Deactivate @\(accumulated-persistence nil)
+  Display statistics ordered by@begin(menu)
+   frames @\(show-accumulated-persistence :frames)  
+   times tried @\(show-accumulated-persistence :tries)
+   ratio @\(show-accumulated-persistence :ratio)
+  @end(menu)
+Break rewrite@begin(menu)
+ Start general rule monitoring @\(brr t)
+ Stop general rule monitoring @\(brr nil)
+ Print monitored runes @\(monitored-runes)
+ Monitor rune: ... @\(monitor '(:definition <event>) 't)
+ Unmonitor rune: ... @\(unmonitor '(:definition <event>))@end(menu)
+ 	
+Commands@begin(menu)
+ Abort to ACL2 top-level @\#.
+ Term being rewritten @\:target
+ Substitution making :lhs equal :target @\:unify-subst
+ Hypotheses @\:hyps
+ Ith hypothesis ... @\:hyp <integer> 
+ Left-hand side of conclusion @\:lhs
+ Right-hand side of conclusion @\:rhs
+ Type assumptions governing :target @\:type-alist
+ Ttree before :eval @\:initial-ttree
+ Negations of backchaining hyps pursued @\:ancestors
+	
+ Rewrite's path from top clause to :target @\:path
+ Top-most frame in :path @\:top
+ Ith frame in :path ... @\:frame <integer>@end(menu)
+	
+AFTER :EVAL@begin(menu)
+ Did application succeed? @\:wonp
+ Rewritten :rhs @\:rewritten-rhs
+ Ttree @\:final-ttree
+ Reason rule failed @\:failure-reason@end(menu)
+
+CONTROL@begin(menu)
+ Exit break @\:ok
+ Exit break, printing result @\:go
+ Try rule and re-enter break afterwards @\:eval@end(menu)
+
+WITH NO RECURSIVE BREAKS@begin(menu)
+ :ok! @\(:ok!)
+ :go! @\(:go!)
+ :eval! @\(:eval!)@end(menu)
+
+WITH RUNES MONITORED DURING RECURSION@begin(menu)
+ :ok  ... @\(:ok$ sexpr)
+ :go ... @\(:go$  sexpr)
+ :eval ... @\(:eval$ sexpr)@end(menu)
+ Help @\(:help)@end(menu)
+ Enter ACL2 Loop @\(lp)
+ Quit to Common Lisp @\:Q
+ ABORT @\(:good-bye)
+@end(menu)
+
+Settings@begin(menu)
+
+Mode @begin(menu)
+ Logic   @\ (logic)
+ Program @\ (program)
+ Guard checking on  @\(set-guard-checking t)
+ Guard checking off @\(set-guard-checking nil)@end(menu)
+
+Forcing@begin(menu)
+ On @\(enable-forcing)
+ Off @\(disable-forcing)@end(menu)
+
+Compile functions@begin(menu)
+ On @\(set-compile-fns t)
+ Off @\(set-compile-fns nil)@end(menu)
+
+Proof tree@begin(menu)
+ Start prooftree @\(start-proof-tree)pre (start-proof-tree nil))
+ Stop prooftree @\(stop-proof-tree)post (stop-proof-tree))
+ Checkpoint forced goals on @\(checkpoint-forced-goals)@end(menu)
+
+Inhibit Display of @begin(menu)
+ Error messages @\(assign inhibit-output-lst '(error))
+ Warnings @\(assign inhibit-output-lst '(warning))
+ Observations @\(assign inhibit-output-lst '(observation))
+ Proof commentary @\(assign inhibit-output-lst '(prove))
+ Proof tree @\(assign inhibit-output-lst '(prove))
+ Non-proof commentary @\(assign inhibit-output-lst '(event))
+ Summary @\(assign inhibit-output-lst '(summary))@end(menu)
+
+Unused Variables@begin(menu)
+ Ignore @\(set-ignore-ok t)
+ Fail @\(set-ignore-ok nil)
+ Warn @\(set-ignore-ok :warn)@end(menu)
+
+Irrelevant formulas@begin(menu)
+ Ok @\(set-irrelevant-formals-ok t)
+ Fail @\(set-irrelevant-formals-ok nil)
+ Warn @\(set-irrelevant-formals-ok :warn)@end(menu)
+
+Load@begin(menu)
+Error action@begin(menu)
+ Continue @\(set-ld-error-actions :continue)
+ Return @\(set-ld-error-actions :return)
+ Error @\(set-ld-error-actions :error)@end(menu)
+
+Error triples@begin(menu)
+ On @\(set-ld-error-triples t)
+ Off @\(set-ld-error-triples nil)@end(menu)
+
+Post eval print@begin(menu)
+ On @\(set-ld-post-eval-print t)
+ Off @\(set-ld-post-eval-print nil)
+ Command conventions @\(set-ld-post-eval-print :command-conventions)@end(menu)
+
+Pre eval filter@begin(menu)
+ All @\(set-ld-pre-eval-filter :all)
+ Query @\(set-ld-pre-eval-filter :query)@end(menu)
+
+Prompt@begin(menu)
+ On @\(set-ld-prompt t)
+ Off @\(set-ld-prompt nil)@end(menu)
+
+Skip proofs@begin(menu)
+ On @\(set-ld-skip-proofs t)
+ Off @\(set-ld-skip-proofs nil)@end(menu)
+
+Verbose: on@begin(menu)
+ On @\(set-ld-verbose t)
+ Off @\(set-ld-verbose nil)@end(menu)
+
+ Redefinition permitted @\(redef)
+ Reset specials @\(reset-ld-specials t)
+HACKERS. DANGER!@begin(menu)
+ RED redefinition! @\(redef!)@end(menu)
+@end(menu)
+
+
+Books@begin(menu)	
+ Print connected book directory @\(cbd)
+ Set connected book directory ... @\(set-cbd filename)
+ Certify-book ... @\(certify-book filename)
+ Include-book ... @\(include-book filename)@end(menu)
+
+ACL2 Help@begin(menu)  
+ Documentation @\(doc '<symbol>)
+ Arguments @\(args '<symbol>)
+ More @\(more)
+ Apropos ... @\(docs '<symbol>)
+ Info @\(cl2-info)
+ Tutorial @\(acl2-info-tutorial)
+ Release Notes @\(cl2-info-release-notes)@end(menu)
+
+@end(menu)
+@end(menu)
+
+
+
+@subsubsection<INFERIOR ACL2 POPUP MENU>
+
+@begin(menu)
+ Recent events @\(pbt '(:here -10))
+ Print Event @\(pe '<symbol>)
+ Print back to @\(pbt '<cd>)
+ Disable @\(in-theory (disable <symbol>))
+ Enable @\(in-theory (enable <symbol>))
+ Undo @\(ubt ':here)
+ Undo thru @\(ubt '<cd>)
+ Documentation @\(doc '<symbol>)
+ Arguments, etc @\(args '<symbol>)
+ Verify @\Take clicked on form into interactive prover.
+@end(menu)
+
+@subsubsection<KEYS>
+
+@begin(menu)
+C-x C-e @\Eval last sexp
+C-c C-l @\Load file
+C-c C-a @\Show arglist
+C-c C-d @\Describe symbol
+C-c C-f @\Show function documentation
+C-c C-v @\Show variable documentation
+C-cl    @\Load file
+C-ck    @\Compile file
+C-ca    @\Show arglist
+C-cd    @\Describe symbol
+C-cf    @\Show function documentation
+C-cv    @\Show variable documentation
+@end(menu)
+
--- /dev/null
+++ acl2-6.0/interface/emacs/load-shell-acl2.el
@@ -0,0 +1,31 @@
+
+;; Load the emacs interface for acl2 when it is running in a 
+;; shell buffer in shell-mode.
+;; May 13 94 Kaufmann & MKSmith
+
+;; ASSUMPTION: load path contains the directory this file resides in.
+
+(defvar *acl2-user-map-interface*
+  '((prooftree-mode-map keys)))
+
+(require 'key-interface)
+
+;; (defvar *selected-mode-map*)
+(defvar inferior-acl2-buffer)
+
+(defun initialize-mfm-buffer-variables ()
+  (setq *mfm-buffer* "*shell*")
+  ;; (setq *selected-mode-map* shell-mode-map)
+  (setq inferior-acl2-buffer *mfm-buffer*))
+
+(defvar shell-mode-hook nil)
+(setq shell-mode-hook
+      (extend-hook shell-mode-hook 'initialize-mfm-buffer-variables))
+
+(defun start-shell-acl2 ()
+  (interactive)
+  (require 'shell)
+  ;; Looks redundant.
+  ;;(setq shell-mode-hook
+	;;(extend-hook 'initialize-mfm-buffer-variables shell-mode-hook))
+  (shell))
--- /dev/null
+++ acl2-6.0/interface/emacs/inf-acl2.el
@@ -0,0 +1,623 @@
+;;; inf-acl2.el --- an inferior-acl2 mode
+;;; Copyright (C) 1988, 1993, 1994 Free Software Foundation, Inc.
+
+;; Copied from inf-lisp.el
+;; As modified for Acl2 by M. K. Smith (mksmith@cli.com), Feb 17 94
+;; Keywords: processes, acl2
+
+;; Original Author: Olin Shivers <shivers@cs.cmu.edu>
+;; Keywords: processes, lisp
+
+;;; This file is part of GNU Emacs.
+
+;;; GNU Emacs is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2, or (at your option)
+;;; any later version.
+
+;;; GNU Emacs is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Emacs; see the file COPYING.  If not, write to
+;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;;; Hacked from inf-lisp.el,  Feb 17 94 MKS 
+;;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88
+
+;;; This file defines an acl2-in-a-buffer package (inferior-acl2
+;;; mode) built on top of comint mode.  This version is more
+;;; featureful, robust, and uniform than the Emacs 18 version.  The
+;;; key bindings are also more compatible with the bindings of Hemlock
+;;; and Zwei (the Lisp Machine emacs).
+
+;;; Since this mode is built on top of the general command-interpreter-in-
+;;; a-buffer mode (comint mode), it shares a common base functionality, 
+;;; and a common set of bindings, with all modes derived from comint mode.
+;;; This makes these modes easier to use.
+
+;;; For documentation on the functionality provided by comint mode, and
+;;; the hooks available for customising it, see the file comint.el.
+;;; For further information on inferior-lisp mode, see the comments below.
+
+;;; Needs fixin:
+;;; The load-file/compile-file default mechanism could be smarter -- it
+;;; doesn't know about the relationship between filename extensions and
+;;; whether the file is source or executable. If you compile foo.lisp
+;;; with compile-file, then the next load-file should use foo.bin for
+;;; the default, not foo.lisp. This is tricky to do right, particularly
+;;; because the extension for executable files varies so much (.o, .bin,
+;;; .lbin, .mo, .vo, .ao, ...).
+;;;
+;;; It would be nice if inferior-lisp (and inferior scheme, T, ...) modes
+;;; had a verbose minor mode wherein sending or compiling defuns, etc.
+;;; would be reflected in the transcript with suitable comments, e.g.
+;;; ";;; redefining fact". Several ways to do this. Which is right?
+;;;
+;;; When sending text from a source file to a subprocess, the process-mark can 
+;;; move off the window, so you can lose sight of the process interactions.
+;;; Maybe I should ensure the process mark is in the window when I send
+;;; text to the process? Switch selectable?
+
+;;; Code:
+
+(require 'comint)
+(require 'acl2-mode)
+
+;; Was defined in comint, but not any more.
+;; (defun full-copy-sparse-keymap (km)
+;;  "Recursively copy the sparse keymap KM."
+;;  (cond ((consp km)
+;;	 (cons (full-copy-sparse-keymap (car km))
+;;	       (full-copy-sparse-keymap (cdr km))))
+;;	(t km)))
+
+
+;;;###autoload
+(defvar inferior-acl2-program "acl2"
+  ;; or perhaps, "nacl2" or "/slocal/src/acl2/new/allegro-saved_acl2"
+  "*Program name for invoking an inferior Acl2 for inferior Acl2 mode.")
+
+;;;###autoload
+;;;(defvar inferior-acl2-initialization "(in-package \"acl2\")(lp)\n"
+;;;  "String sent to set initial Acl2 state.")
+(defvar inferior-acl2-initialization ""
+  "String sent to set initial Acl2 state.")
+
+;;;###autoload
+(defvar inferior-acl2-load-command
+  "(ld \"%s\" :ld-pre-eval-print t :ld-error-action :return :ld-verbose nil)\n"
+  "*Format-string for building an Acl2 expression to load a file.
+This format string should use `%s' to substitute a file name
+and should result in an expression that will command the inferior Acl2
+to load that file.
+
+The default setting commands the inferior Acl2 to load the file,
+printing the form before evaling but suppressing the ACL2 version
+info.")
+
+;; (defvar inferior-acl2-silent-load-command
+;;   "(ld \"%s\" :ld-pre-eval-print nil :ld-error-action :return :ld-verbose nil )\n"
+;;   "*Format-string for building an Acl2 expression to load a temporary file.
+;; This format string should use `%s' to substitute a file name
+;; and should result in an expression that will command the inferior Acl2
+;; to load that file with a minimum of verbosity.")
+
+;;;###autoload
+(defvar inferior-acl2-prompt "^[ACL2]* *[!+]*>+ *"
+  "Regexp to recognise prompts in the inferior Acl2 mode.
+This variable is used to initialize `comint-prompt-regexp' in the 
+inferior Acl2 buffer.")
+
+;;;###autoload
+(defvar inferior-acl2-filter-regexp "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'"
+  "*What not to save on inferior Acl2's input history.
+Input matching this regexp is not saved on the input history in inferior Acl2
+mode.  Default is whitespace followed by 0 or 1 single-letter colon-keyword 
+(as in :a, :c, etc.)")
+
+(defvar inferior-acl2-mode-map nil)
+(cond ((not inferior-acl2-mode-map)
+       (setq inferior-acl2-mode-map (copy-keymap comint-mode-map))
+       (set-keymap-parent inferior-acl2-mode-map (acl2-shared-lisp-mode-map))))
+
+
+;;; This function exists for backwards compatibility.
+;;; Previous versions of this package bound commands to C-c <letter>
+;;; bindings, which is not allowed by the gnumacs standard.
+
+;;;  "This function binds many inferior-acl2 commands to C-c <letter> bindings,
+;;;where they are more accessible. C-c <letter> bindings are reserved for the
+;;;user, so these bindings are non-standard. If you want them, you should
+;;;have this function called by the inferior-acl2-load-hook:
+;;;    (setq inferior-acl2-load-hook '(inferior-acl2-install-letter-bindings))
+;;;You can modify this function to install just the bindings you want."
+
+;;; ??? This function was commented out.  Added back. Jul 22 94 MKS 
+
+(defun temporary-filename (id)
+  (format "/tmp/lisp%d.lisp" id))
+
+(defvar inferior-acl2-buffer "*inferior-acl2*"
+"*The current inferior-acl2 process buffer.
+
+MULTIPLE PROCESS SUPPORT
+===========================================================================
+To run multiple Lisp processes, you start the first up
+with \\[inferior-acl2].  It will be in a buffer named `*inferior-acl2*'.
+Rename this buffer with \\[rename-buffer].  You may now start up a new
+process with another \\[inferior-acl2].  It will be in a new buffer,
+named `*inferior-acl2*'.  You can switch between the different process
+buffers with \\[switch-to-buffer].
+
+Commands that send text from source buffers to Lisp processes --
+like `acl2-eval-event' or `acl2-show-arglist' -- have to choose a process
+to send to, when you have more than one Lisp process around.  This
+is determined by the global variable `inferior-acl2-buffer'.  Suppose you
+have three inferior Acl2 running:
+    Buffer              Process
+    foo                 inferior-acl2
+    bar                 inferior-acl2<2>
+    *inferior-acl2*     inferior-acl2<3>
+If you do a \\[acl2-eval-event] command on some Lisp source code, 
+what process do you send it to?
+
+- If you're in a process buffer (foo, bar, or *inferior-acl2*), 
+  you send it to that process.
+- If you're in some other buffer (e.g., a source file), you
+  send it to the process attached to buffer `inferior-acl2-buffer'.
+This process selection is performed by function `inferior-acl2-proc'.
+
+Whenever \\[inferior-acl2] fires up a new process, it resets
+`inferior-acl2-buffer' to be the new process's buffer.  If you only run
+one process, this does the right thing.  If you run multiple
+processes, you can change `inferior-acl2-buffer' to another process
+buffer with \\[set-variable].")
+
+;;;###autoload
+(defvar inferior-acl2-mode-hook '()
+  "*Hook for customising inferior Acl2 mode.")
+
+(defvar inferior-acl2-filter-regexp "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'"
+  "*What not to save on inferior Acl2's input history.
+Input matching this regexp is not saved on the input history in Inferior Acl2
+mode.  Default is whitespace followed by 0 or 1 single-letter colon-keyword 
+(as in :a, :c, etc.)")
+
+(defvar comint-input-sentinel)
+
+(defun inferior-acl2-mode () 
+  "Major mode for interacting with an inferior Acl2 process.  
+Runs Acl2 as a subprocess of Emacs, with Acl2 I/O through an
+Emacs buffer.  Variable `inferior-acl2-program' controls which version of
+Acl2 is run.  Variables `inferior-acl2-prompt', `inferior-acl2-filter-regexp' and
+`inferior-acl2-load-command' can customize this mode for different 
+keyword sensitive effects.
+
+For information on running multiple processes in multiple buffers, see
+documentation for variable `inferior-acl2-buffer'.
+
+\\{inferior-acl2-mode-map}
+
+Customisation: Entry to this mode runs the hooks on `comint-mode-hook' and
+`inferior-acl2-mode-hook' (in that order).
+
+You can send text to the inferior Acl2 process from other buffers containing
+Acl2 source.  
+    switch-to-acl2 switches the current buffer to the Lisp process buffer.
+    acl2-eval-event sends the current defun to the Acl2 process.
+    acl2-eval-region sends the current region to the Acl2 process.
+
+    Prefixing the acl2-eval-event/region commands with
+    a \\[universal-argument] causes a switch to the Acl2 process buffer 
+    after sending the text.
+
+Commands:
+Return after the end of the process' output sends the text from the 
+    end of process to point.
+Return before the end of the process' output copies the sexp ending at point
+    to the end of the process' output, and sends it.
+Delete converts tabs to spaces as it moves back.
+Tab indents for Acl2; with argument, shifts rest
+    of expression rigidly with the current line.
+C-M-q does Tab on each line starting within following expression.
+Paragraphs are separated only by blank lines.  Semicolons start comments.
+If you accidentally suspend your process, use \\[comint-continue-subjob]
+to continue it."
+  (interactive)
+  (comint-mode)
+  (setq comint-prompt-regexp inferior-acl2-prompt)
+  (setq major-mode 'inferior-acl2-mode)
+  (setq mode-name "Inferior Acl2")
+  ;; ???
+  (setq mode-line-process '(": %s"))
+
+  ;;; ??? This was changed to (lisp-mode-variables nil).
+  ;;; Back to acl2-mode.   Jul 22 94 MKS 
+
+  (acl2-mode-variables t)
+  (use-local-map inferior-acl2-mode-map)
+  ;; Extend acl2-mode, now that we have an inferior.
+  ;; (inferior-acl2-extend-acl2-mode-map)
+  ;; Now done in acl2-interface.
+  (setq comint-get-old-input (function acl2-get-old-input))
+  (setq comint-input-filter (function acl2-input-filter))
+  (setq comint-input-sentinel 'ignore)
+  (run-hooks 'inferior-acl2-mode-hook))
+
+(defun acl2-get-old-input ()
+  "Return a string containing the sexp ending at point."
+  (save-excursion
+    (let ((end (point)))
+      (backward-sexp)
+      (buffer-substring (point) end))))
+
+(defun acl2-input-filter (str)
+  "t if STR does not match `inferior-acl2-filter-regexp'."
+  (not (string-match inferior-acl2-filter-regexp str)))
+
+;;;###autoload
+(defun inferior-acl2 (cmd)
+  "Run an inferior Acl2 process, input and output via buffer `*inferior-acl2*'.
+If there is a process already running in `*inferior-acl2*', just switch
+to that buffer.
+With argument, allows you to edit the command line (default is value
+of `inferior-acl2-program').  Runs the hooks from
+`inferior-acl2-mode-hook' (after the `comint-mode-hook' is run).
+\(Type \\[describe-mode] in the process buffer for a list of commands.)"
+
+  ;; Note comment from MAKE-COMINT:
+  ;;   Make a comint process NAME in a buffer, running PROGRAM.
+  ;;   The name of the buffer is made by surrounding NAME with `*'s."
+  ;; Thus the apply below will create a buffer named "*inferior-acl2*"
+
+  (interactive (list (if current-prefix-arg
+			 (read-string "Run lisp: " inferior-acl2-program)
+		       inferior-acl2-program)))
+  (if (not (comint-check-proc "*inferior-acl2*"))
+      (let ((cmdlist (inferior-acl2-args-to-list cmd)))
+	(set-buffer (apply (function make-comint)
+			   "inferior-acl2" (car cmdlist) nil (cdr cmdlist)))
+	(inferior-acl2-mode)
+	(comint-send-string (inferior-acl2-proc) inferior-acl2-initialization)))
+  (setq inferior-acl2-buffer "*inferior-acl2*")
+  (switch-to-buffer "*inferior-acl2*"))
+
+;;;###autoload
+(defalias 'run-acl2 'inferior-acl2)
+
+;;; Break a string up into a list of arguments.
+;;; This will break if you have an argument with whitespace, as in
+;;; string = "-ab +c -x 'you lose'".
+(defun inferior-acl2-args-to-list (string)
+  (let ((where (string-match "[ \t]" string)))
+    (cond ((null where) (list string))
+	  ((not (= where 0))
+	   (cons (substring string 0 where)
+		 (inferior-acl2-args-to-list (substring string (+ 1 where)
+							(length string)))))
+	  (t (let ((pos (string-match "[^ \t]" string)))
+	       (if (null pos)
+		   nil
+		 (inferior-acl2-args-to-list (substring string pos
+							(length string)))))))))
+
+;; send-region-to-acl2-process disappeared
+;; ??? Restored.   Jul 22 94 MKS 
+
+;; Hacked for inf-acl2 mode.  Feb 28 94 MKS 
+(defun send-region-to-acl2-process (begin end other-window-p)
+  "Writes the region of the current buffer delimited by begin and end
+   to a temporary file.  If other-window-p is not nil the buffer is selected
+   in the other window, otherwise it is selected in the current window (unless
+   it is currently exposed in another window)."
+	  
+  (let* ((process (inferior-acl2-proc))
+	 (buffer-to-select (process-buffer process))
+	 (cmd-string inferior-acl2-load-command)
+	 (filename (temporary-filename (process-id process)))
+	 (in-package-form-written nil))
+    
+    ;; Write any IN-PACKAGE form (occuring immediately after a linefeed) 
+    ;; preceeding this region. Bevier. 11/5/90
+    (save-excursion
+      (goto-char begin)
+      (if (re-search-backward "\n(in-package" 0 t)
+	  (let ((b (point)))
+	    (forward-sexp 1)
+	    (let ((e (point)))
+	      (setq in-package-form-written t)
+	      (write-region b e filename nil 'nomessage)))))
+
+    (write-region begin end filename in-package-form-written 'nomessage)
+    (process-send-string process (format cmd-string filename))
+    (if other-window-p (switch-to-acl2 t))))
+
+(defvar *inf-acl2-debug-send* nil)
+(defvar *inf-acl2-debug-send-string* nil)
+
+(defvar verify-wrapper "(lisp %s)\n")
+(defvar verify-prompt-string "->: ")
+
+(defvar *inf-acl2-echo* t)
+
+(defun inf-acl2-send-string (command &optional arg)
+  ;; Some printing by Acl2 assumes you are already on 
+  ;; a new line.  But since comint-send-string doesn't
+  ;; echo this is not always a correct assumption. 
+  (if (bufferp (get-buffer inferior-acl2-buffer))
+      (let ((string (format command arg)))
+	(let ((process (inferior-acl2-proc))
+	      (string (format command arg))
+	      verify)
+	  (set-buffer inferior-acl2-buffer)
+	  (goto-char (process-mark process))
+	  (save-excursion
+	    (beginning-of-line)
+	    (setq verify (looking-at verify-prompt-string)))
+	  (if verify (setq string (format verify-wrapper string)))
+	  ;; The \n below adds a blank line that makes things more 
+	  ;; readable.
+	  (if *inf-acl2-echo* (progn (insert string) (insert "\n")))
+	  (set-marker (process-mark process) (point))
+	  ;; (set-marker comint-last-output-start (point))
+	  ;; (set-marker comint-last-input-end (point))
+	  (if *inf-acl2-debug-send*
+	      (setq *inf-acl2-debug-send-string* string))
+	  (comint-send-string process string)))
+      (error "No inferior Acl2 buffer")))
+
+;; acl2-eval-region, acl2-eval-event, and acl2-eval-last-sexp disappeared
+;; ??? Restored.   Jul 22 94 MKS 
+
+(defun acl2-eval-region (start end &optional and-go)
+  "Send the current region to the inferior Acl2 process.
+Prefix argument means switch to the inferior Acl2 buffer afterwards."
+  (interactive "r\nP")
+  (goto-char end)
+  (send-region-to-acl2-process start end (or and-go *acl2-eval-and-go*)))
+
+(defun acl2-eval-event (&optional and-go)
+  "Send the current defun to the inferior Acl2 process.
+Prefix argument means switch to the inferior Acl2 buffer afterwards."
+  (interactive "P")
+  (save-excursion
+    (condition-case nil
+	(end-of-defun)
+      (error (error "Current form unbalanced")))
+    (skip-chars-backward " \t\n\r\f") ;  Makes allegro happy
+    (let ((end (point)))
+      (beginning-of-defun)
+      ;; Rather than passing the and-go to eval-region we 
+      ;; start the eval and then reposition in this buffer
+      ;; before switching.
+      (acl2-eval-region (point) end)))
+  ;; Same as lisp-eval-defun-and-move
+  ;; Deleted at Bevier's request  Apr 20 95 MKS 
+  ;; (end-of-defun)
+  (if (or and-go *acl2-eval-and-go*) (switch-to-acl2 t)))
+
+(defun acl2-eval-last-sexp (&optional and-go)
+  "Send the previous sexp to the inferior Acl2 process.
+Prefix argument means switch to the inferior Acl2 buffer afterwards."
+  (interactive "P")
+  (acl2-eval-region (save-excursion (backward-sexp) (point)) (point)
+		    (or and-go *acl2-eval-and-go*)))
+
+(defun switch-to-acl2 (eob-p)
+  "Switch to the inferior Acl2 process buffer.
+With argument, positions cursor at end of buffer."
+  (interactive "P")
+  (if (get-buffer inferior-acl2-buffer)
+      (pop-to-buffer inferior-acl2-buffer)
+    (error "No current inferior Acl2 buffer"))
+  (cond (eob-p
+	 (push-mark)
+	 (goto-char (point-max)))))
+
+(defun switch-to-acl2-eof ()
+  "Switch to the inferior Acl2 process buffer &
+position cursor at end of buffer."
+  (interactive)
+  (if (get-buffer inferior-acl2-buffer)
+      (pop-to-buffer inferior-acl2-buffer)
+    (error "No current inferior Acl2 buffer"))
+  (push-mark)
+  (goto-char (point-max)))
+
+
+;;; Now that acl2-compile/eval-event/region takes an optional prefix arg,
+;;; these commands are redundant. But they are kept around for the user
+;;; to bind if he wishes, for backwards functionality, and because it's
+;;; easier to type C-c e than C-u C-c C-e.
+
+(defun acl2-eval-region-and-go (start end)
+  "Send the current region to the inferior Acl2, and switch to its buffer."
+  (interactive "r")
+  (acl2-eval-region start end t))
+
+(defun acl2-eval-event-and-go ()
+  "Send the current defun to the inferior Acl2, and switch to its buffer."
+  (interactive)
+  (acl2-eval-event t))
+
+(defvar acl2-prev-l/c-dir/file nil
+  "Record last directory and file used in loading or compiling.
+This holds a cons cell of the form `(DIRECTORY . FILE)'
+describing the last `acl2-load-file' or `acl2-compile-file' command.")
+
+(defvar acl2-source-modes '(acl2-mode)
+  "Used to determine if a buffer contains Acl2 source code.
+If it's loaded into a buffer that is in one of these major modes, it's
+considered an Acl2 source file by `acl2-load-file' and `acl2-compile-file'.
+Used by these commands to determine defaults.")
+
+(defun acl2-load-file (file-name)
+  "Load an Acl2 file into the inferior Acl2 process."
+  ;; 4th param below is NIL because LOAD doesn't need an exact name.
+  ;; But what about LD?
+  (interactive (comint-get-source "Load Acl2 file: " acl2-prev-l/c-dir/file
+				  acl2-source-modes nil)) 
+  (comint-check-source file-name) ; Check to see if buffer needs saved.
+  (setq acl2-prev-l/c-dir/file (cons (file-name-directory    file-name)
+				     (file-name-nondirectory file-name)))
+  (comint-send-string (inferior-acl2-proc)
+		      (format inferior-acl2-load-command file-name))
+  (switch-to-acl2 t))
+
+
+;;; Documentation functions: function doc, var doc, arglist, and
+;;; describe symbol.
+;;; ===========================================================================
+
+;;; Ancillary functions
+;;; ===================
+
+;;; Reads a string from the user.
+(defun acl2-symprompt (prompt default)
+  (list (let* ((prompt (if default
+			   (format "%s (default %s): " prompt default)
+			 (concat prompt ": ")))
+	       (ans (read-string prompt)))
+	  (if (zerop (length ans)) default ans))))
+
+
+;;; Adapted from function-called-at-point in help.el.
+(defun acl2-fn-called-at-pt ()
+  "Returns the name of the function called in the current call.
+The value is nil if it can't find one."
+  (condition-case nil
+      (save-excursion
+	(save-restriction
+	  (narrow-to-region (max (point-min) (- (point) 1000)) (point-max))
+	  (backward-up-list 1)
+	  (forward-char 1)
+	  (let ((obj (acl2-var-at-pt)))
+	    (and (symbolp obj) obj))))
+    (error nil)))
+
+;;; Adapted from variable-at-point in help.el.
+(defun acl2-var-at-pt ()
+  (condition-case ()
+      (save-excursion
+	(forward-sexp 1)
+	(forward-sexp -1)
+	(skip-chars-forward "'")
+	(let* ((begin (point))
+	       (max (save-excursion (end-of-line) (point)))
+	       (end (- (re-search-forward "[ ,()\\.!?#|`';']" max t) 1))
+	       (obj (car (read-from-string (buffer-substring begin end)))))
+	  (and (symbolp obj) obj)))
+    (error nil)))
+
+
+;;; Documentation functions: fn and var doc, arglist, and symbol describe.
+;;; ======================================================================
+
+(defun inf-acl2-last-line-to-top ()
+  (save-excursion
+    (set-buffer inferior-acl2-buffer)
+    (goto-char (point-max))
+    (this-line-to-top)))
+
+(defun inferior-acl2-proc ()
+  "Returns the current inferior Acl2 process.
+See variable `inferior-acl2-buffer'."
+  (let ((proc (get-buffer-process (if (eq major-mode 'inferior-acl2-mode)
+				      (current-buffer)
+				    inferior-acl2-buffer))))
+    (or proc
+	(error "No Acl2 subprocess; see variable `inferior-acl2-buffer'"))))
+
+;; Try to unwedge Acl2.
+
+(defun acl2-abort-mystery-wedge ()
+  (interactive)
+  ;; (let ((inferior-acl2-load-command ":q\n"))
+  ;;   (acl2-send-sexp-and-go))
+  (comint-send-string (inferior-acl2-proc) ":q\n"))
+
+
+;;; Do the user's customisation...
+;;;===============================
+(defvar inferior-acl2-load-hook nil
+  "This hook is run when the library `inf-acl2' is loaded.
+This is a good place to put keybindings.")
+
+(run-hooks 'inferior-acl2-load-hook)
+
+;;; CHANGE LOG
+;;; ===========================================================================
+;;;  Feb 17 94 MKS - See inf-lisp.el
+
+(provide 'inf-acl2)
+
+;;; inf-acl2.el ends here.
+
+
+;;; Unused
+;; 
+;; (defun acl2-show-function-documentation (fn)
+;;   "Send a command to the inferior Acl2 to give documentation for function FN.
+;; See variable `acl2-function-doc-command'."
+;;   (interactive (acl2-symprompt "Function doc" (acl2-fn-called-at-pt)))
+;;   (inf-acl2-last-line-to-top)
+;;   (comint-proc-query (inferior-acl2-proc)
+;; 		     (format acl2-function-doc-command fn)))
+;; 
+;; (defun acl2-describe-sym (sym)
+;;   "Send a command to the inferior Acl2 to describe symbol SYM.
+;; See variable `acl2-describe-sym-command'."
+;;   (interactive (acl2-symprompt "Describe" (acl2-var-at-pt)))
+;;   (inf-acl2-last-line-to-top)
+;;   (comint-proc-query (inferior-acl2-proc)
+;; 		     (format acl2-describe-sym-command sym)))
+;; 
+;; 
+;; (defun acl2-show-function-documentation (fn)
+;;   "Send a command to the inferior Acl2 to give documentation for function FN.
+;; See variable `acl2-function-doc-command'."
+;;   (interactive (acl2-symprompt "Function doc" (acl2-fn-called-at-pt)))
+;;   (inf-acl2-last-line-to-top)
+;;   (comint-proc-query (inferior-acl2-proc)
+;; 		     (format acl2-function-doc-command fn)))
+;; 
+;; (defun acl2-show-variable-documentation (var)
+;;   "Send a command to the inferior Acl2 to give documentation for function FN.
+;; See variable `acl2-var-doc-command'."
+;;   (interactive (acl2-symprompt "Variable doc" (acl2-var-at-pt)))
+;;   (inf-acl2-last-line-to-top)
+;;   (comint-proc-query (inferior-acl2-proc) (format acl2-var-doc-command var)))
+;; 
+;; (defun acl2-show-arglist (fn)
+;;   "Send a query to the inferior Acl2 for the arglist for function FN.
+;; See variable `acl2-arglist-command'."
+;;   (interactive (acl2-symprompt "Arglist" (acl2-fn-called-at-pt)))
+;;   (inf-acl2-last-line-to-top)
+;;   (comint-proc-query (inferior-acl2-proc) (format acl2-arglist-command fn)))
+;; 
+;; (defun acl2-describe-sym (sym)
+;;   "Send a command to the inferior Acl2 to describe symbol SYM.
+;; See variable `acl2-describe-sym-command'."
+;;   (interactive (acl2-symprompt "Describe" (acl2-var-at-pt)))
+;;   (inf-acl2-last-line-to-top)
+;;   (comint-proc-query (inferior-acl2-proc)
+;; 		     (format acl2-describe-sym-command sym)))
+;; 
+;; (defun acl2-show-arglist (fn)
+;;   "Send a query to the inferior Acl2 for the arglist for function FN.
+;; See variable `acl2-arglist-command'."
+;;   (interactive (acl2-symprompt "Arglist" (acl2-fn-called-at-pt)))
+;;   (inf-acl2-last-line-to-top)
+;;   (comint-proc-query (inferior-acl2-proc) (format acl2-arglist-command fn)))
+;; 
+;; (defun acl2-show-variable-documentation (var)
+;;   "Send a command to the inferior Acl2 to give documentation for function FN.
+;; See variable `acl2-var-doc-command'."
+;;   (interactive (acl2-symprompt "Variable doc" (acl2-var-at-pt)))
+;;   (inf-acl2-last-line-to-top)
+;;   (comint-proc-query (inferior-acl2-proc) (format acl2-var-doc-command var)))
--- /dev/null
+++ acl2-6.0/interface/emacs/load-inferior-acl2.el
@@ -0,0 +1,29 @@
+
+;; Load the emacs interface for acl2 and start it running in an
+;; inferior-acl2 buffer.
+
+;; May 13 94 Kaufmann & MKSmith
+;; Sep 25 94 MKSmith
+
+;; THIS GOES IN THE USER'S .emacs FILE,
+;; after loadpath is set to include this dir.
+
+; BEGIN INSERT after this line
+; 
+; (autoload 'run-acl2
+;   "top-start-inferior-acl2" 
+;   "Open communication between acl2 running in shell and prooftree." t)
+;
+;  END INSERT before this line
+
+(require 'acl2-interface)		;loads everything else
+
+(defun initialize-mfm-buffer-variables ()
+  (setq *mfm-buffer* inferior-acl2-buffer))
+
+(setq inferior-acl2-mode-hook
+	(extend-hook inferior-acl2-mode-hook 'initialize-mfm-buffer-variables))
+
+(defun load-inferior-acl2 ()
+  (interactive)
+  (run-acl2 inferior-acl2-program))
--- /dev/null
+++ acl2-6.0/interface/emacs/README-mouse
@@ -0,0 +1,6 @@
+See the documentation topic PROOF-TREE-EMACS for how to start up and use proof
+trees with emacs.  Also see PROOF-TREE for other information about proof trees.
+
+The file README-mouse.doc in this directory explains additional features, not
+currently supported though they may work, provided by this interface -- notably
+mouse/menu support.
--- /dev/null
+++ acl2-6.0/interface/emacs/README-mouse.doc
@@ -0,0 +1,519 @@
+             The ACL2 Prooftree and Mouse Interface
+
+
+                    M. Kaufmann & M. K. Smith
+
+
+
+1.  Introduction
+
+NOTE:  This interface should be considered preliminary, although
+it has been used successfully at Computational Logic, Inc.  It is
+not part of the ACL2 software in the strictest sense (which is
+co-authored by Matt Kaufmann and J Moore), but we feel that it
+will be useful to ACL2 users.
+
+This note describes how to get the ACL2/Emacs prooftree and mouse
+support.  You just need to add a single autoload form to your
+.emacs file.  And then issue the correspoding M-x command.
+
+The prooftree support has been tested in the following Emacs:
+
+ Emacs 18
+ Emacs 19        - with comint and WFS's shell, sshell.el.
+ Lemacs 19
+
+The menu and mouse support currently works with Emacs 19.
+
+If you don't want to deal with any of this:  You probably want to
+put the following form in your acl2-customization.lisp file.
+
+ :STOP-PROOF-TREE
+
+This will turn off the proof tree printing from ACL2.  For
+documentation in ACL2 do
+ :doc proof-tree
+To turn proof trees back on use `:START-PROOF-TREE'.
+NOTE: If you do `:STOP-PROOF-TREE' in ACL2, then M-x
+start-proof-tree will not accomplish anything useful in Emacs.
+
+
+2.  LOADING EMACS INTERFACE CODE
+
+
+2.1  Simplest .emacs Additions
+
+If you want the full interface, put the following in your .emacs
+file after replacing /projects/acl2/v2-x/ with the full
+pathname of your acl2-sources/ directory.
+
+ (setq *acl2-interface-dir*
+   "/projects/acl2/v2-x/interface/emacs/")
+
+ (autoload 'run-acl2 ;;emacs 19.27 only at this time
+   (concat *acl2-interface-dir* "top-start-inferior-acl2")
+   "Begin ACL2 in an inferior ACL2 mode buffer."
+   t)
+
+Then, to get things started in Emacs do `M-x run-acl2'.  Use `M-x
+acl2-mode' to get `<acl2-file>.lisp' into the right mode.  The
+commands in the various modes are listed in a later section.  But
+you can see most of them by observing the new pull-down menus and
+pop-up menu in inferior ACL2 mode and ACL2 mode.  The pop-up menu
+is tied to mouse-3.
+
+If you just want proof trees, use the following after replacing
+/projects/acl2/v2-x/ with the full pathname of your
+acl2-sources/ directory.
+
+ (setq *acl2-interface-dir*
+   "/projects/acl2/v2-x/interface/emacs/")
+
+(autoload 'start-proof-tree
+  (concat *acl2-interface-dir* "top-start-shell-acl2")
+  "Enable proof tree logging in a prooftree buffer."
+  t)
+
+
+
+2.2  More Control from .emacs: Setting preferences
+
+The alist, *acl2-user-map-interface*, determines what menus you
+get.  If a feature is included after a mode name, then you get
+it.
+
+(defvar *acl2-user-map-interface*
+  '((inferior-acl2-mode menu-bar popup-menu keys)
+    (acl2-mode          menu-bar popup-menu keys)
+    (prooftree-mode     menu-bar popup-menu keys)))
+
+
+If you set the following to T, you will switch to the inferior
+ACL2 buffer when you send forms, regions, or buffers to it.
+
+ (setq *acl2-eval-and-go* nil)
+
+If you set the following to NIL you will be queried for their
+values when you start up a prooftree buffer (via M-x
+start-proof-tree).  These are the defaults you get based on the
+autoload above.
+
+ (setq *acl2-proof-tree-height* 17)
+ (setq *checkpoint-recenter-line* 3)
+
+
+
+3.  Commands
+
+Commands are enabled based on the value of the alist,
+*acl2-user-map-interface*, as described above.  There are some
+conventions that you need to know regarding arguments to mouse
+commands.
+
+If a menu bar entry is of the form
+
+   Print event ...
+
+the "..." indicates that you will be prompted in the minibuffer
+for an argument.
+
+If a menu bar entry is of the form
+
+   Mode >
+
+the ">" indicates a suborninate menu that will pop up if you
+release on this menu item.
+
+Pop-up menu items indicate whether they take an argument based on
+a preceding ".".  The argument is determined by what you clicked
+on to bring up the menu.  Arguments derived from things that
+appear in the chronology are somewhat robust.  So that if you had
+a list of events on the screen like:
+         13  (DEFMACRO TEXT (X) ...)
+ L       14  (DEFUN MSG-P (X) ...)
+ L       15  (DEFUN MAKE-PACKET (X Y Z) ...)
+ L       16  (DEFUN HISTORY-P (L) ...)
+         17  (DEFMACRO INFROM (X) ...)
+to see event 14 you could click right anywhere on that line and
+select either ". Print Event" or ". Print Command".
+
+
+3.1  Prooftree Related
+
+   M-x start-proof-tree
+   M-x stop-proof-tree
+
+
+3.2  Prooftree Mode
+
+
+3.2-A  POPUP MENU
+
+   Abort               Abort *inferior-acl2*.
+   Goto subgoal        Go to clicked on subgoal in *inferior-acl2*.
+   Resume proof tree   Resume printing proof tree.
+   Suspend proof tree  Suspend printing proof tree.
+   Checkpoint/Suspend  Suspend prooftree and go to clicked on checkpoint.
+   Checkpoint          Go to clicked on checkpoint.
+   Help
+
+
+3.2-B  MENU BAR
+
+   Prooftree
+
+       Checkpoint      Go to next checkpoint
+       Goto subgoal    That cursor is on.
+       Checkpoint / Suspend    Go to next checkpoint and suspend proof tree.
+       Resume proof tree
+       Suspend proof tree
+       Abort           Abort prooftree. (ACL2 will continue to send prooftrees, it just
+                       won't go the the prooftree buffer.)
+       Help
+
+
+3.2-C  KEYS
+
+   C-z z               Previous C-z key binding
+   C-z c               Go to checkpoint
+   C-z s               Suspend proof tree
+   C-z r               Resume proof tree
+   C-z a               Mfm abort secondary buffer
+   C-z g               Goto subgoal
+   C-z h               help
+   C-z ?               help
+
+
+3.3  ACL2 Mode
+
+ACL2 Mode is like Lisp mode except that the functions that send
+sexprs to the inferior Lisp process expect an inferior ACL2
+process in the *inferior-acl2* buffer.
+
+
+3.3-A  POPUP MENU
+
+   Send to ACL2        Send top level form clicked on to ACL2.
+   Add hint            Add the hint form to the clicked on defun.
+
+      Do not induct.
+      Do not generalize.
+      Do not fertilize.
+      Expand           expand form. Requests you mouse it.
+      Hands off.
+      Disable          Disable symbol. Requests you mouse it.
+      Enable           Enable symbol. Requests you mouse it.
+      Induct           Induct based on form. Requests you mouse it.
+      Cases            Perform case split on form.Requests you mouse it.
+
+   Go to inferior ACL2
+   Verify              Take clicked on form into interactive prover.
+
+
+3.3-B  KEYS
+
+   C-x C-e             eval last sexp
+   C-c C-r             eval region
+   C-M-x               eval defun
+   C-c C-e             eval defun
+   C-c C-z             switch to ACL2
+   C-c C-l             load file
+   C-c C-a             show arglist
+   C-c C-d             describe symbol
+   C-c C-f             show function documentation
+   C-c C-v             show variable documentation
+   C-ce                eval defun and go to ACL2
+   C-cr                eval region and go to ACL2
+
+
+3.4  Inferior ACL2 Mode
+
+
+3.4-A  MENU BAR
+
+   Events
+
+       Recent events   (pbt '(:here -10))
+       Print back through ...  (pbt <event>)
+       Undo            (ubt ':here)
+       Oops            (oops)
+       Undo through ...   (ubt '<event>)
+       Undo through ...   (ubt! '<cd>)
+
+       Load file ...   (cl2-load-file)
+
+       Disable ...     (in-theory (disable <symbol>))
+       Enable ...      (in-theory (enable <symbol>))
+
+       Verify guards ...  (verify-guards '<symbol>)
+       Verify termination ...  (verify-guards '<symbol>)
+
+       Certify-book ...   (certify-book <filename>)
+       Include-book ...   (include-book <filename> )
+
+      Compound commands
+
+          Expand compound command ...  (puff '<cd>)
+          Expand compound command! ...   (puff* '<cd>)
+
+      Table
+
+          Print value ...   (table symbol)
+          Clear ...    (table <symbol> nil nil :clear
+          Print guard ...   (table <symbol> nil nil :guard)
+
+   Print
+
+       Event ...       (pe 'event)
+       Event! ...      (pe! 'event)
+       Back through ...   (pbt 'event)
+
+       Command ...     (pc '<cd>)
+       Command block ...  (pcb '<cd>)
+       Full Command block ...  (pcb! '<cd>)
+
+       Signature ...   (args 'event)
+       Formula ...     (pf 'event)
+       Properties ...  (props 'event)
+
+       Print connected book directory    (cbd)
+
+       Rules whose top function symbol is ...   (pl 'event)
+       Rules stored by event ...    (pr 'event)
+       Rules stored by command ...  (pr! '<cd>)
+
+       Monitored-runes    (monitored-runes)
+
+   Control
+
+       Load ...        (ld filename)
+       Accumulated Persistence
+
+           Activate    (accumulated-persistence t)
+           Deactivate  (accumulated-persistence nil)
+           Display statistics ordered by
+
+               frames  (show-accumulated-persistence :frames)
+               times tried  (show-accumulated-persistence :tries)
+               ratio   (show-accumulated-persistence :ratio)
+
+         Break rewrite
+
+             Start general rule monitoring  (brr t)
+             Stop general rule monitoring  (brr nil)
+             Print monitored runes  (monitored-runes)
+             Monitor rune: ...  (monitor '(:definition <event>) 't)
+             Unmonitor rune: ...  (unmonitor '(:definition <event>))
+
+         Commands
+
+             Abort to ACL2 top-level  #.
+             Term being rewritten   :target
+             Substitution making :lhs equal :target   :unify-subst
+             Hypotheses   :hyps
+             Ith hypothesis ...  :hyp <integer>
+             Left-hand side of conclusion  :lhs
+             Right-hand side of conclusion  :rhs
+             Type assumptions governing :target  :type-alist
+             Ttree before :eval  :initial-ttree
+             Negations of backchaining hyps pursued   :ancestors
+
+             Rewrite's path from top clause to :target   :path
+             Top-most frame in :path  :top
+             Ith frame in :path ...  :frame <integer>
+
+         AFTER :EVAL
+
+             Did application succeed?  :wonp
+             Rewritten :rhs  :rewritten-rhs
+             Ttree     :final-ttree
+             Reason rule failed  :failure-reason
+
+         CONTROL
+
+             Exit break   :ok
+             Exit break, printing result  :go
+             Try rule and re-enter break afterwards   :eval
+
+         WITH NO RECURSIVE BREAKS
+
+             :ok!      (:ok!)
+             :go!      (:go!)
+             :eval!    (:eval!)
+
+         WITH RUNES MONITORED DURING RECURSION
+
+             :ok  ...  (:ok$ sexpr)
+             :go ...   (:go$  sexpr)
+             :eval ...    (:eval$ sexpr)
+
+          Help         (:help)
+
+       Enter ACL2 Loop    (lp)
+       Quit to Common Lisp  :Q
+       ABORT           (:good-bye)
+
+   Settings
+
+      Mode
+
+          Logic         (logic)
+          Program       (program)
+          Guard checking on    (set-guard-checking t)
+          Guard checking off   (set-guard-checking nil)
+
+      Forcing
+
+          On           (enable-forcing)
+          Off          (disable-forcing)
+
+      Compile functions
+
+          On           (set-compile-fns t)
+          Off          (set-compile-fns nil)
+
+      Proof tree
+
+          Start prooftree   (start-proof-tree)pre (start-proof-tree nil))
+          Stop prooftree  (stop-proof-tree)post (stop-proof-tree))
+          Checkpoint forced goals on  (checkpoint-forced-goals)
+
+      Inhibit Display of
+
+          Error messages  (assign inhibit-output-lst '(error))
+          Warnings     (assign inhibit-output-lst '(warning))
+          Observations    (assign inhibit-output-lst '(observation))
+          Proof commentary  (assign inhibit-output-lst '(prove))
+          Proof tree   (assign inhibit-output-lst '(prove))
+          Non-proof commentary   (assign inhibit-output-lst '(event))
+          Summary      (assign inhibit-output-lst '(summary))
+
+      Unused Variables
+
+          Ignore       (set-ignore-ok t)
+          Fail         (set-ignore-ok nil)
+          Warn         (set-ignore-ok :warn)
+
+      Irrelevant formulas
+
+          Ok           (set-irrelevant-formals-ok t)
+          Fail         (set-irrelevant-formals-ok nil)
+          Warn         (set-irrelevant-formals-ok :warn)
+
+      Load
+
+         Error action
+
+             Continue  (set-ld-error-actions :continue)
+             Return    (set-ld-error-actions :return)
+             Error     (set-ld-error-actions :error)
+
+         Error triples
+
+             On        (set-ld-error-triples t)
+             Off       (set-ld-error-triples nil)
+
+         Post eval print
+
+             On        (set-ld-post-eval-print t)
+             Off       (set-ld-post-eval-print nil)
+             Command conventions  (set-ld-post-eval-print :command-conventions)
+
+         Pre eval filter
+
+             All       (set-ld-pre-eval-filter :all)
+             Query     (set-ld-pre-eval-filter :query)
+
+         Prompt
+
+             On        (set-ld-prompt t)
+             Off       (set-ld-prompt nil)
+
+         Skip proofs
+
+             On        (set-ld-skip-proofs t)
+             Off       (set-ld-skip-proofs nil)
+
+         Verbose: on
+
+             On        (set-ld-verbose t)
+             Off       (set-ld-verbose nil)
+
+          Redefinition permitted  (redef)
+          Reset specials  (reset-ld-specials t)
+         HACKERS. DANGER!
+
+             RED redefinition!  (redef!)
+
+
+      Books
+
+          Print connected book directory   (cbd)
+          Set connected book directory ...  (set-cbd filename)
+          Certify-book ...  (certify-book filename)
+          Include-book ...  (include-book filename)
+
+      ACL2 Help
+
+          Documentation   (doc '<symbol>)
+          Arguments    (args '<symbol>)
+          More         (more)
+          Apropos ...  (docs '<symbol>)
+          Release Notes   (cl2-info-release-notes)
+
+
+
+3.4-B  INFERIOR ACL2 POPUP MENU
+
+    Recent events      (pbt '(:here -10))
+    Print Event        (pe '<symbol>)
+    Print back to      (pbt '<cd>)
+    Disable            (in-theory (disable <symbol>))
+    Enable             (in-theory (enable <symbol>))
+    Undo               (ubt ':here)
+    Undo thru          (ubt '<cd>)
+    Documentation      (doc '<symbol>)
+    Arguments, etc     (args '<symbol>)
+    Verify             Take clicked on form into interactive prover.
+
+
+3.4-C  KEYS
+
+   C-x C-e             Eval last sexp
+   C-c C-l             Load file
+   C-c C-a             Show arglist
+   C-c C-d             Describe symbol
+   C-c C-f             Show function documentation
+   C-c C-v             Show variable documentation
+   C-cl                Load file
+   C-ck                Compile file
+   C-ca                Show arglist
+   C-cd                Describe symbol
+   C-cf                Show function documentation
+   C-cv                Show variable documentation
+
+             The ACL2 Prooftree and Mouse Interface
+
+
+
+                         Table of Contents
+
+
+
+    1. Introduction  . . . . . . . . . . . . . . . . . . . .    1
+    2. LOADING EMACS INTERFACE CODE  . . . . . . . . . . . .    1
+      2.1. Simplest .emacs Additions . . . . . . . . . . . .    1
+      2.2. More Control from .emacs: Setting preferences . .    1
+    3. Commands  . . . . . . . . . . . . . . . . . . . . . .    1
+      3.1. Prooftree Related . . . . . . . . . . . . . . . .    1
+      3.2. Prooftree Mode  . . . . . . . . . . . . . . . . .    1
+        3.2-A. POPUP MENU  . . . . . . . . . . . . . . . . .    1
+        3.2-B. MENU BAR  . . . . . . . . . . . . . . . . . .    1
+        3.2-C. KEYS  . . . . . . . . . . . . . . . . . . . .    1
+      3.3. ACL2 Mode   . . . . . . . . . . . . . . . . . . .    1
+        3.3-A. POPUP MENU  . . . . . . . . . . . . . . . . .    1
+        3.3-B. KEYS  . . . . . . . . . . . . . . . . . . . .    2
+      3.4. Inferior ACL2 Mode  . . . . . . . . . . . . . . .    2
+        3.4-A. MENU BAR  . . . . . . . . . . . . . . . . . .    2
+        3.4-B. INFERIOR ACL2 POPUP MENU  . . . . . . . . . .    3
+        3.4-C. KEYS  . . . . . . . . . . . . . . . . . . . .    3
--- /dev/null
+++ acl2-6.0/interface/emacs/top-start-inferior-acl2.el
@@ -0,0 +1,11 @@
+(defvar *acl2-interface-dir*
+  "/slocal/src/acl2/v1-8/interface/emacs/")
+
+(setq *acl2-user-map-interface*
+  '((inferior-acl2-mode-map menu-bar popup-menu keys)
+    (shell-mode-map         menu-bar popup-menu keys)
+    (acl2-mode-map          menu-bar popup-menu keys)
+    (prooftree-mode-map     menu-bar popup-menu keys)))
+
+(let ((load-path (cons *acl2-interface-dir* load-path)))
+  (load "load-inferior-acl2"))
--- /dev/null
+++ acl2-6.0/interface/emacs/key-interface.el
@@ -0,0 +1,106 @@
+
+;; Add key interface for prooftree buffers.
+;; March 3 95 MKS 
+
+;; ----------------------------------------------------------------------
+;; USER SETTINGS
+
+;; (defvar *acl2-proof-tree-height* 17)
+;; (defvar *checkpoint-recenter-line* 3)
+
+;; ----------------------------------------------------------------------
+;; Load all of the various acl2-interface files, if necessary.
+
+(load "mfm-acl2.el")			;(require 'mfm-acl2)
+
+;; (load "interface-macros.el")		;(require 'interface-macros)
+;; Replaced by the following defvar and four functions, which is all this 
+;; file used from interface macros.
+
+;; Begin insert
+
+(defvar mode-menu-alist nil)
+
+;; WARNING:  Be sure that if should-i-install, update-mode-menu-alist,
+;; remove-mode-menu-alist, define-mode-keys, or extend-hook is changed, then it
+;; is also changed in key-interface.el.
+
+(defun should-i-install (mode feature)
+  ;; mode is mode-name
+  (memq feature (cdr (assoc mode mode-menu-alist))))
+
+(defun update-mode-menu-alist (l)
+  (if (not (consp (car l)))
+      (setq l (cons l nil)))
+  (setq mode-menu-alist 
+	(append l (remove-mode-menu-alist mode-menu-alist l))))
+
+(defun remove-mode-menu-alist (alist l)
+  (cond ((null alist) l)
+	((assoc (car (car alist)) l)
+	 (remove-mode-menu-alist (cdr alist) l))
+	(t (cons (car alist) (remove-mode-menu-alist (cdr alist) l)))))
+
+(defun define-mode-keys (mode-map-name mode-map keys)
+  ;; An entry in keys may have two forms:
+  ;; (key function)     
+  ;; (keymap key function)
+  ;; The second allows you to create subkeymaps, e.g. Control-Z
+  (if (should-i-install mode-map-name 'keys)
+      (mapcar
+       (function (lambda (x)
+		   (if (equal (length x) 2)
+		       (define-key mode-map (car x) (car (cdr x)))
+		       (if (keymapp (eval (car x)))
+			   (define-key (eval (car x)) (car (cdr x)) (car (cdr (cdr x))))
+			   (error
+			    (format "Keymap %s not defined in mode %s" (car x) (car mode-map)))))))
+       keys)))
+
+(defun extend-hook (hook entry)
+  ;; Add an entry onto a mode-hook, being sensitive to the
+  ;; stupid Emacs permission for it to be a function or list
+  ;; of functions.
+  (cond ((null hook) (list entry))
+	((symbolp hook) (if (not (equal entry hook)) (list hook entry) hook))
+	((not (consp hook)) 
+	 (message (format "Strange hook, %s, replaced by %s." hook entry))
+	 (list entry))
+	((equal (car hook) 'lambda)
+	 (list hook entry))
+	((member-equal entry hook) hook)
+	(t (append hook (list entry)))))
+
+;; end insert
+
+(update-mode-menu-alist *acl2-user-map-interface*)
+
+;; Defined in mfm-acl2 so that checkpoint-help can use it.
+(defvar prooftree-subkey)
+(setq prooftree-subkey "\C-z")
+
+;; prooftree-subkeymap was set by prooftree-mode.el.  Now do it here.
+(defvar prooftree-subkeymap (make-sparse-keymap))
+
+(defvar old-prooftree-subkey (global-key-binding prooftree-subkey))
+
+(define-key (current-global-map) prooftree-subkey prooftree-subkeymap)
+
+(defconst prooftree-keys
+; WARNING: Keep this in sync with the corresponding definition in
+; acl2-interface.el.
+  (list
+   (list 'prooftree-subkeymap "z" old-prooftree-subkey)
+   (list 'prooftree-subkeymap "c" 'checkpoint)
+   (list 'prooftree-subkeymap "s" 'suspend-proof-tree)
+   (list 'prooftree-subkeymap "r" 'resume-proof-tree)
+   (list 'prooftree-subkeymap "g" 'goto-subgoal)
+   (list 'prooftree-subkeymap "h" 'checkpoint-help)
+   (list 'prooftree-subkeymap "?" 'checkpoint-help)
+   (list 'prooftree-subkeymap "o" 'select-other-frame-with-focus)
+   (list 'prooftree-subkeymap "b" 'visit-proof-tree)
+   (list 'prooftree-subkeymap "B" 'visit-proof-tree-other-frame)))         
+
+(define-mode-keys 'global (current-global-map) prooftree-keys)
+
+(provide 'key-interface)
