debian/0000755000000000000000000000000012230256672007173 5ustar debian/compat0000644000000000000000000000000211440300440010352 0ustar 5 debian/changelog0000644000000000000000000005372312230256621011051 0ustar acl2 (6.3-5) unstable; urgency=low * rebuild against latest gcl -- Camm Maguire Fri, 18 Oct 2013 16:10:57 +0000 acl2 (6.3-4) unstable; urgency=low * set HOME for mini-proveall make -- Camm Maguire Tue, 15 Oct 2013 14:12:15 +0000 acl2 (6.3-3) unstable; urgency=low * set HOME to $(pwd) -- Camm Maguire Mon, 14 Oct 2013 15:09:48 +0000 acl2 (6.3-2) unstable; urgency=low * build dep against latest gcl -- Camm Maguire Sat, 12 Oct 2013 01:46:31 +0000 acl2 (6.3-1) unstable; urgency=low * New upstream release -- Camm Maguire Wed, 02 Oct 2013 20:19:51 +0000 acl2 (6.2-8) unstable; urgency=low * Allow certification failures for 1) dlopen machines, as we cannot control the surpassed 1024 maximum dlopen limit, and 2) machines with an insufficient hard limit on data segment size (e.g. kfreebsd-i386, or any machine which cannot brk 1Gb). * add build-dep on texinfo * add upstream certificate relocation patch to other-events.lisp -- Camm Maguire Mon, 09 Sep 2013 15:27:04 +0000 acl2 (6.2-7) unstable; urgency=low * build-dep against latest gcl * again allow optimize-maximum-pages in elementary-bounders.acl2 -- Camm Maguire Tue, 06 Aug 2013 11:30:55 +0000 acl2 (6.2-6) unstable; urgency=low * fix elementary-bounders.acl2 -- Camm Maguire Mon, 29 Jul 2013 18:54:53 +0000 acl2 (6.2-5) unstable; urgency=low * (setq si::*optimize-maximum-pages* nil) in elementary-bounders.acl2 * build-dep against latest gcl -- Camm Maguire Sat, 27 Jul 2013 12:49:46 +0000 acl2 (6.2-4) unstable; urgency=low * build-dep against latest gcl -- Camm Maguire Tue, 23 Jul 2013 18:11:51 +0000 acl2 (6.2-3) unstable; urgency=low * build-dep against latest gcl -- Camm Maguire Sat, 20 Jul 2013 02:21:17 +0000 acl2 (6.2-2) unstable; urgency=low * Add (in-package :acl2) preceeding save-exec in final cert image modification stage to support #-native-reloc targets -- Camm Maguire Mon, 15 Jul 2013 16:34:41 +0000 acl2 (6.2-1) unstable; urgency=low * New upstream release -- Camm Maguire Thu, 11 Jul 2013 22:02:56 +0000 acl2 (6.1-6) unstable; urgency=low * build-dep against latest gcl -- Camm Maguire Tue, 02 Jul 2013 16:10:25 +0000 acl2 (6.1-5) unstable; urgency=low * reinstate skipped books and build depend on latest gcl -- Camm Maguire Fri, 21 Jun 2013 23:14:46 +0000 acl2 (6.1-4) unstable; urgency=low * skip books/centaur/vl/transforms/xf-sizing.lisp, which takes too much memory -- Camm Maguire Sun, 26 May 2013 03:50:49 +0000 acl2 (6.1-3) unstable; urgency=low * skip books/centaur/defrstobj/basic-tests.lisp, which takes too much memory -- Camm Maguire Thu, 23 May 2013 13:20:29 +0000 acl2 (6.1-2) unstable; urgency=low * skip elementary-bounders.lisp certification, which takes too much memory -- Camm Maguire Tue, 21 May 2013 17:15:51 +0000 acl2 (6.1-1) unstable; urgency=low * New upstream release -- Camm Maguire Tue, 23 Apr 2013 14:52:39 +0000 acl2 (6.0-3) unstable; urgency=low * Lintian cleanups * certify centaur books with memory adjustments (lint.acl2, top.acl2) -- Camm Maguire Thu, 17 Jan 2013 23:12:05 +0000 acl2 (6.0-2) unstable; urgency=low * HOME="/tmp" environment for make DOC -- Camm Maguire Sun, 13 Jan 2013 17:54:15 +0000 acl2 (6.0-1) unstable; urgency=low * New upstream release -- Camm Maguire Mon, 07 Jan 2013 21:45:40 +0000 acl2 (5.0-1) unstable; urgency=low * New upstream release * books retrieved separately from http://acl2-books.googlecode.com/files/books-5.0.tar.gz * Bug fix: "Should build-depend on emacs23 | emacs24", thanks to svante.signell@telia.com; (Closes: #682719). -- Camm Maguire Fri, 24 Aug 2012 18:45:28 +0000 acl2 (4.3-3) unstable; urgency=low * Bug fix: "unowned file /usr/local/share/texmf/ls-R after purge (policy 6.8, 9.1.2)", thanks to Andreas Beckmann (Closes: #669380). * Bug fix: "FTBFS: | /«PKGBUILDDIR»/books/tools/defsum.c:7456:5: error: expected expression before ')' token", thanks to Lucas Nussbaum (Closes: #669442). Build-dep on latest gcl -- Camm Maguire Fri, 20 Apr 2012 12:59:26 +0000 acl2 (4.3-2) unstable; urgency=low * remove special NO_STRIP for ppc * multiply-stacks by 4 on #-native-reloc * Bug fix: "Please add support for build-arch and build-indep targets", thanks to Niels Thykier (Closes: #647919). -- Camm Maguire Fri, 20 Jan 2012 14:18:55 +0000 acl2 (4.3-1) unstable; urgency=low * New upstream release -- Camm Maguire Mon, 09 Jan 2012 21:41:00 +0000 acl2 (4.1-5) unstable; urgency=low * build depend on latest gcl * turn off si::*optimize-maximum-pages* in reverse-by-separation.acl2 * remove unnecessary patch from serialize-tests.lisp -- Camm Maguire Fri, 05 Nov 2010 16:19:11 +0000 acl2 (4.1-4) unstable; urgency=low * build dep on latest gcl -- Camm Maguire Wed, 27 Oct 2010 20:47:24 +0000 acl2 (4.1-3) unstable; urgency=low * build-dep latest gcl * Bug fix: "FTBFS on mips: Terminated", thanks to Cyril Brulebois (Closes: #599946). * Bug fix: "FTBFS on mipsel: Unrecoverable error: Segmentation violation..", thanks to Cyril Brulebois (Closes: #599998). -- Camm Maguire Wed, 20 Oct 2010 16:15:56 +0000 acl2 (4.1-2) unstable; urgency=low * build-dep latest gcl * Bug fix: "FTBFS (powerpc): ls: cannot access tiny.cert: No such file or directory", thanks to Philipp Kern (Closes: #597278). -- Camm Maguire Thu, 23 Sep 2010 12:44:54 +0000 acl2 (4.1-1) unstable; urgency=low * New upstream release -- Camm Maguire Sun, 05 Sep 2010 00:27:43 +0000 acl2 (4.0-3) unstable; urgency=low * compile nats to avoid invocation stack overflow on #-native-reloc machines -- Camm Maguire Fri, 09 Jul 2010 13:00:12 +0000 acl2 (4.0-2) unstable; urgency=low * Work around absence of HOME in buildd environments. -- Camm Maguire Thu, 08 Jul 2010 16:14:04 +0000 acl2 (4.0-1) unstable; urgency=low * New upstream release -- Camm Maguire Wed, 07 Jul 2010 21:49:46 +0000 acl2 (3.6.1-2) unstable; urgency=low * Bug fix: "acl2 depends on old / broken emacs22 package", thanks to Andreas Barth (Closes: #585405). * lintian fixes -- Camm Maguire Thu, 10 Jun 2010 14:09:37 +0000 acl2 (3.6.1-1) unstable; urgency=low * New upstream release -- Camm Maguire Sun, 06 Jun 2010 19:58:55 +0000 acl2 (3.6-4) unstable; urgency=low * Bug fix: "FTBFS [hppa] - **CERTIFICATION FAILED** for ram2b.lisp", thanks to dann frazier (Closes: #564247). -- Camm Maguire Mon, 11 Jan 2010 17:44:36 +0000 acl2 (3.6-3) unstable; urgency=low * Bug fix: "FTBFS on kfreebsd-i386: /bin/sh: line 1: 42209 Segmentation fault gcl < workxxx", thanks to Cyril Brulebois (Closes: #563604). -- Camm Maguire Mon, 04 Jan 2010 18:12:16 +0000 acl2 (3.6-2) unstable; urgency=low * Bug fix: "FTBFS [alpha, hppa] - getprop.cert: No such file or directory", thanks to dann frazier (Closes: #562207). Build-depend on gcl >= 2.6.7-51. * Bug fix: "adds non-existent TAGS file to tag file list", thanks to Timo Juhani Lindfors (Closes: #505812). Don't automatically load tags table. -- Camm Maguire Sun, 03 Jan 2010 13:26:38 +0000 acl2 (3.6-1) unstable; urgency=low * New upstream release [ Camm Maguire ] * Bug fix: "replacing libreadline5-dev build dependency with libreadline-dev", thanks to Matthias Klose (Closes: #553715). -- Camm Maguire Tue, 15 Dec 2009 03:53:25 +0000 acl2 (3.4-2) unstable; urgency=low * New maintainer address * sparc sgc workaround -- disable sgc here only -- Camm Maguire Mon, 23 Feb 2009 01:54:24 +0000 acl2 (3.4-1) unstable; urgency=low * New upstream release * Bug fix: "acl2-status.txt should contain :INITIALIZED.", thanks to Lucas Nussbaum (Closes: #494328). New release works around compiler issue. * Bug fix: "FTBFS when converted to new source format 3.0 (quilt)", thanks to hertzog@debian.org; (Closes: #482594). patches -> dpatches -- Camm Maguire Sun, 24 Aug 2008 21:26:46 +0000 acl2 (3.3-1.1) unstable; urgency=low * Non-maintainer upload. * Build depend on time, so that it works with shells other than bash (Closes: #459060). -- Peter Eisentraut Sat, 05 Apr 2008 18:49:49 +0200 acl2 (3.3-1) unstable; urgency=low * New upstream release * build-dep on latest gcl to get arm build * Bug fix: "acl2's idea of the system book path is wrong", thanks to Sami Liedes (Closes: #440353). Apply suggested fix to wrapper script, Thanks! * Bug fix: "acl2-emacs: please prefer emacs22", thanks to Tatsuya Kinoshita (Closes: #434915). prefer emacs22 * Bug fix: "acl2: not binNMU safe", thanks to Lior Kaplan (Closes: #430471). Apply suggested patch, Thanks! * build-dep texlive-latex-recommended -- Camm Maguire Mon, 03 Dec 2007 10:10:09 -0500 acl2 (3.2-1) unstable; urgency=low * New upstream release -- Camm Maguire Thu, 17 May 2007 10:41:35 -0400 acl2 (3.1-1) unstable; urgency=low * New upstream release -- Camm Maguire Mon, 4 Dec 2006 10:35:42 -0500 acl2 (3.0.1-8) unstable; urgency=low * Fix dlopen.lisp.in -- Camm Maguire Thu, 19 Oct 2006 12:52:10 -0400 acl2 (3.0.1-7) unstable; urgency=low * Build dep on libxmu-dev libxaw7-dev -- Camm Maguire Wed, 18 Oct 2006 16:36:26 -0400 acl2 (3.0.1-6) unstable; urgency=low * really change dlopen * build dep on gcl_2.6.7-27 -- Camm Maguire Tue, 17 Oct 2006 18:19:47 -0400 acl2 (3.0.1-5) unstable; urgency=low * Add user::*fast-acl2-gcl-build* and user::*acl2-keep-tmp-files* parameters to dlopen following upstream * Build-Depend on gcl_2.6.7-26 -- Camm Maguire Mon, 16 Oct 2006 18:05:05 -0400 acl2 (3.0.1-4) unstable; urgency=low * Build-Depend on gcl_2.6.7-25 -- Camm Maguire Thu, 12 Oct 2006 14:41:53 -0400 acl2 (3.0.1-3) unstable; urgency=low * Build-Depend on gcl_2.6.7-23 * Newer standards -- Camm Maguire Wed, 11 Oct 2006 11:09:29 -0400 acl2 (3.0.1-2) unstable; urgency=low * rebuild against newer gcl -- Camm Maguire Wed, 30 Aug 2006 18:53:50 -0400 acl2 (3.0.1-1) unstable; urgency=low * New upstream release -- Camm Maguire Wed, 2 Aug 2006 17:02:24 +0000 acl2 (3.0-1) unstable; urgency=low * New upstream release * acl2-books-source and acl2-books-certs depend on mathcing version of acl2, Closes: #339032. * Fix emacs startup for xemacs -- remove error only, no autosetup of tags table for xemacs, appears impossible. Closes: #349401 -- Camm Maguire Sat, 10 Jun 2006 17:42:09 +0000 acl2 (2.9.4-1) unstable; urgency=low * New upstream release -- Camm Maguire Wed, 23 Nov 2005 23:31:29 +0000 acl2 (2.9.3-7) unstable; urgency=low * build depend on >= gcl-2.6.7-11 to get default maxpage fix for amd64, Closes: #323666. -- Camm Maguire Thu, 20 Oct 2005 12:46:17 +0000 acl2 (2.9.3-6) unstable; urgency=low * build depend on >= gcl-2.6.7-10 to get ppc gcc configure fix -- Camm Maguire Thu, 13 Oct 2005 18:36:11 +0000 acl2 (2.9.3-5) unstable; urgency=low * build depend on >= gcl 2.6.7-8 for 64bit fasd data/fixnum fix -- Camm Maguire Wed, 5 Oct 2005 19:15:41 +0000 acl2 (2.9.3-4) unstable; urgency=low * build depend on >= gcl 2.6.7-8 for 64bit bignum/fixnum fix -- Camm Maguire Sun, 2 Oct 2005 11:23:30 +0000 acl2 (2.9.3-3) unstable; urgency=low * Build-depend on gcl >= 2.6.7-7 to get dlopen fix needed for mips, alpha, hppa, and ia64 * rework build strategy switching based on the native-reloc feature in the installed gcl. -- Camm Maguire Thu, 29 Sep 2005 18:32:02 +0000 acl2 (2.9.3-2) unstable; urgency=high * Depend on gcl 2.6.7-6 or greater with its own binutils included, remove dependency on binutils-dev -- Camm Maguire Tue, 20 Sep 2005 19:49:42 +0000 acl2 (2.9.3-1) unstable; urgency=low * New upstream release * probe-file -> truename *infix-directory* patch for gcl 2.6.7 -- Camm Maguire Fri, 12 Aug 2005 20:57:23 +0000 acl2 (2.9.2-1) unstable; urgency=low * New upstream release -- Camm Maguire Mon, 25 Apr 2005 14:00:42 +0000 acl2 (2.9.1-1) unstable; urgency=high * New upstream release * Bug fix: "acl2: :system dir is wrong", thanks to Patrick Calhoun (Closes: #284780). Apologies, had inadvertently reverted previous fix. Now include a GNUmakefile patch setting ACL2_BOOKS_DIR. -- Camm Maguire Tue, 22 Feb 2005 18:34:32 +0000 acl2 (2.9-3) unstable; urgency=low * Update README.Debian regarding building auxiliary workshops and non-std packages -- Camm Maguire Sat, 8 Jan 2005 19:03:36 +0000 acl2 (2.9-2) unstable; urgency=high * Don't strip saved_acl2 on powerpc, see #210809. -- Camm Maguire Fri, 5 Nov 2004 21:39:50 +0000 acl2 (2.9-1) unstable; urgency=high * New upstream release * Remove nullification of allocation list from debian/patches.in * Add debian/dlopen.lisp for building on ia64,mips(el),alpha and hppa * Revert to upstream build procedure on all other platforms * doc-notes.txt is gone (from acl2-emacs.doc) * mv nsaved_acl2.gcl saved_acl2 for backward compatibility with 2.8, as we provide our own shell script wrapper. * Remove debian/acl2-doc.info in favor of compile-time generated command line arguments to dh_installinfo -- Camm Maguire Mon, 25 Oct 2004 13:29:46 +0000 acl2 (2.8-6) unstable; urgency=low * acl2 suggests acl2-emacs -- Camm Maguire Thu, 7 Oct 2004 14:40:35 +0000 acl2 (2.8-5) unstable; urgency=low * Bug fix: "acl2-emacs: ACL2 emacs mode produces an error on acl2 defstobjs definition", thanks to David (Closes: #260112). Small patch to acl2-mode.el added to debian/patches. * Build depend on latest gcl for performance and stability improvements. -- Camm Maguire Fri, 17 Sep 2004 13:11:05 +0000 acl2 (2.8-4) unstable; urgency=low * Bug fix: "FTBFS: missing Build-Depends binutils-dev", thanks to Goswin von Brederlow (Closes: #251695). Make build-depends on binutils-dev valid for all platforms -- Camm Maguire Mon, 31 May 2004 18:32:56 +0000 acl2 (2.8-3) unstable; urgency=low * move doc-notes.txt to acl2-emacs * copyright and control file clarifications * removal of Debian specific files from distribution list in READE.Debian * addition of arithmetic-axioms.txt and fast-notes.txt to acl2-doc * Removal of .final certificate extension from list in README.Debian * doc-base rephrasing * (setq *acl2-allocation-alist* nil) in debian/patches.in for enhanced performance with recent gcl -- Camm Maguire Tue, 11 May 2004 20:45:14 +0000 acl2 (2.8-2) unstable; urgency=low * Bug fix: "acl2: :system dir is wrong", thanks to Cesar Eduardo Barros (Closes: #246721). Supply final system directory in POST variable in debian/rules. -- Camm Maguire Fri, 30 Apr 2004 18:54:36 +0000 acl2 (2.8-1) unstable; urgency=low * New upstream release * Bug fix: "Inefficient packaging of arch independent data", thanks to Steve McIntyre (Closes: #232883). Split package into several components. -- Camm Maguire Fri, 16 Apr 2004 03:35:25 +0000 acl2 (2.7-9) unstable; urgency=low * Build depend on latest gcl to try SAFE_FREAD fix for m68k and SGC runtime check as alpha libc bug workaround * echo any failed mini-proveall results * require full test to succeed for build to complete -- Camm Maguire Thu, 12 Feb 2004 15:08:14 +0000 acl2 (2.7-8) unstable; urgency=low * Fix bad directory names pertaining to earlier version * Capitalize ACL2 in doc-base file * Cleanup copyright file * Replace build directory with install directory in cert files * Apply fix to proof-checker-b.lisp * Add a placeholder manpage * remove dh-make template files * newer standards * dh_compat 4 * cleanup gcl build dependencies * build-depend on >= gcl-2.6.1-23 for readline fixes * debian/patches mechanism to build cert files with correct pathnames at time of installation * README.Debian clarifying ACL2 vs. ACL2(r) * Patch to banner indicating binary includes corrected proof-checker.lisp * Remove Makefiles from distribution, replace with .acl2 files as discussed with upstream * Add bdd/bit-vector-reader.lsp and bdd/be/* files to distribution as requested by upstream * Add TAGS file for source perusal, and modify tags-table-list in emacs startup file * distribute lisp files in interface/infix * Protect interface/infix/sloop.lisp with #-gcl and restore to distribution and makefile * doinfix an acl2 example * Add emacs/doc-notes.txt as acl2 doc file * Add note in man page about availability of online documentation * Add .txt and .html files from books/textbook to acl2-doc package * mv CLI.sty into /usr/share/texmf/tex/latex, run texhash on postinst and postrm, and depend on tetex-extra * updated fsf address in copyright file * gathered all patches outside the debian/ subdir into patches.in, so that apt-get -q source acl2 will produce a pristine tree for the user as requested upstream. * Add table of source and binary file locations in README.Debian as requested by upstream * Updated watch file for new upstream links -- Camm Maguire Thu, 5 Feb 2004 15:22:05 +0000 acl2 (2.7-7) unstable; urgency=low * More verbose testing output to overcome autobuild timeout problems -- Camm Maguire Tue, 10 Dec 2002 13:20:34 -0500 acl2 (2.7-6) unstable; urgency=low * new gcl for m68k, Closes: #171593 -- Camm Maguire Thu, 5 Dec 2002 08:30:11 -0500 acl2 (2.7-5) unstable; urgency=low * New gcl fixes for arm * cat to build log failed cert output -- Camm Maguire Mon, 25 Nov 2002 10:13:16 -0500 acl2 (2.7-4) unstable; urgency=low * Fix bad patch -- Camm Maguire Thu, 21 Nov 2002 23:40:09 -0500 acl2 (2.7-3) unstable; urgency=low * New gcl on m68k to fix cache flushes, Closes: #170084 * Book certification failures not fatal for now -- Camm Maguire Thu, 21 Nov 2002 17:53:51 -0500 acl2 (2.7-2) unstable; urgency=low * Build-depends on tetex-base -- Camm Maguire Tue, 19 Nov 2002 20:11:39 -0500 acl2 (2.7-1) unstable; urgency=low * New upstream release * new modules linear-a linear-b and non-linear * certify all books -- Camm Maguire Mon, 18 Nov 2002 20:26:16 -0500 acl2 (2.6-15) unstable; urgency=low * Correct final pathnames in certs * remove TMP1.lisp -- Camm Maguire Sun, 17 Nov 2002 16:36:09 -0500 acl2 (2.6-14) unstable; urgency=low * Fix bad diff, Closes #169493 -- Camm Maguire Sun, 17 Nov 2002 12:28:46 -0500 acl2 (2.6-13) unstable; urgency=low * Fix acl2 path issue in infix subbuild -- Camm Maguire Sun, 17 Nov 2002 08:58:20 -0500 acl2 (2.6-12) unstable; urgency=low * Turn off default-system-p in final image * tests in build target to avoid fakeroot bug on ia64, better here anyway * increased files distributed as recommended by upstream * emacs interface fixes to support all Debian emacs flavors -- Camm Maguire Sat, 16 Nov 2002 23:22:25 -0500 acl2 (2.6-11) unstable; urgency=low * Build-depends on binutils-dev for arches using bfd -- Camm Maguire Wed, 13 Nov 2002 21:35:22 -0500 acl2 (2.6-10) unstable; urgency=low * Added missing Build-deps: Closes: #168968 -- Camm Maguire Wed, 13 Nov 2002 14:04:32 -0500 acl2 (2.6-9) unstable; urgency=low * gcl >= -67 for ppc and m68k -- Camm Maguire Wed, 13 Nov 2002 12:02:44 -0500 acl2 (2.6-8) unstable; urgency=low * New portable gcl build mechanism for acl2, Closes: #167618 -- Camm Maguire Sun, 10 Nov 2002 12:48:44 -0500 acl2 (2.6-7) unstable; urgency=low * Add test targets * acl2-mode.el fix, Closes: #167356 -- Camm Maguire Sun, 10 Nov 2002 12:48:37 -0500 acl2 (2.6-6) unstable; urgency=low * Better (less restrictive) gcl Build-Depends * Newer standards * acl2-doc in section doc -- Camm Maguire Thu, 31 Oct 2002 21:49:44 -0500 acl2 (2.6-5) unstable; urgency=low * Patch acl2-mode.el to handle differing xemacs/emacs behavior, Closes: #167012 -- Camm Maguire Wed, 30 Oct 2002 11:58:20 -0500 acl2 (2.6-4) unstable; urgency=low * Rerelease to use new gcl with fixes on ia64, hppa and arm -- Camm Maguire Tue, 29 Oct 2002 20:30:42 -0500 acl2 (2.6-3) unstable; urgency=low * Add emacs21 | emacsen, debhelper to Build-Deps -- Camm Maguire Mon, 28 Oct 2002 18:40:07 -0500 acl2 (2.6-2) unstable; urgency=low * Fix emacsen and info post-install -- Camm Maguire Sat, 26 Oct 2002 21:34:36 -0400 acl2 (2.6-1) unstable; urgency=low * Initial Release. -- Camm Maguire Sat, 26 Oct 2002 11:58:58 -0400 debian/dlopen.lisp.in0000644000000000000000000001503211440300440011734 0ustar (in-package 'compiler) (defun make-user-init (files outn) (let* ((c (pathname outn)) (c (merge-pathnames c (make-pathname :directory '(:current)))) (o (merge-pathnames (make-pathname :type "o") c)) (c (merge-pathnames (make-pathname :type "c") c))) (with-open-file (st c :direction :output) (format st "#include ~a~%~%" *cmpinclude*) (format st "#define load2(a) do {") (format st "printf(\"Loading %s...\\n\",(a));") (format st "load(a);") (format st "printf(\"Finished %s...\\n\",(a));} while(0)~%~%") (let ((p nil)) (dolist (tem files) (when (equal (pathname-type tem) "o") (let ((tem (namestring tem))) (push (list (si::find-init-name tem) tem) p)))) (setq p (nreverse p)) (dolist (tem p) (format st "extern void ~a(void);~%" (car tem))) (format st "~%") (format st "typedef struct {void (*fn)(void);char *s;} Fnlst;~%") (format st "#define NF ~a~%" (length p)) (format st "static Fnlst my_fnlst[NF]={") (dolist (tem p) (when (not (eq tem (car p))) (format st ",~%")) (format st "{~a,\"~a\"}" (car tem) (cadr tem))) (format st "};~%~%") (format st "static int user_init_run;~%") (format st "#define my_load(a_,b_) {if (!user_init_run && (a_) && (b_)) gcl_init_or_load1((a_),(b_));(a_)=0;(b_)=0;}~%~%") (format st "object user_init(void) {~%") (format st "user_init_run=1;~%") (dolist (tem files) (let ((tem (namestring tem))) (cond ((equal (cadr (car p)) tem) (format st "gcl_init_or_load1(~a,\"~a\");~%" (car (car p)) tem) (setq p (cdr p))) (t (format st "load2(\"~a\");~%" tem))))) (format st "return Cnil;}~%~%") (format st "int user_match(const char *s,int n) {~%") (format st " Fnlst *f;~%") (format st " for (f=my_fnlst;fs && !strncmp(s,f->s,n)) {~%") (format st " my_load(f->fn,f->s);~%") (format st " return 1;~%") (format st " }~%") (format st " }~%") (format st " return 0;~%") (format st "}~%~%"))) (compiler-cc c o) (delete-file c) o)) (in-package 'user) (let ((si::*collect-binary-modules* t) ;; Collect a list of names of each object file loaded si::*binary-modules* (compiler::*default-system-p* t));; .o files to be linked in via ld ;; must be compiled with :system-p t (let ((com (quote ;; This is a command to build acl2 which will be run twice -- ;; once in stock gcl, compiling files, loading and recording same ;; once in an image which is linked via ld from the results of the above ;; redirecting each load to an initialization of the .o file already ;; linked into the image by ld (progn (load "init.lisp") (let* ((la (find-symbol "LOAD-ACL2" "ACL2")) ;; acl2::load-acl2 doesn't exist at read-time (olf (symbol-function la)) (si::*collect-binary-modules* t)) ;; make sure the second pass watches for ;; .o loads, for the purpose of triggering an error (unless (probe-file "axioms.o") ;; no sense to compile twice (funcall (symbol-function (find-symbol "COMPILE-ACL2" "ACL2"))) (delete-package "ACL2-PC")) ;; prevent package error when loading after compiling (funcall olf) ;; must load-acl2 to establish the symbols below (defparameter user::*fast-acl2-gcl-build* t) (defparameter user::*acl2-keep-tmp-files* :no-pid) (let ((sa (find-symbol "SAVE-ACL2" "ACL2")) (ia (find-symbol "INITIALIZE-ACL2" "ACL2")) (ib (find-symbol "INCLUDE-BOOK" "ACL2")) (ap2f (find-symbol "*ACL2-PASS-2-FILES*" "ACL2")) (ocf (symbol-function 'compiler::compile)) (osf (symbol-function 'si::save-system))) (setf (symbol-function 'compiler::compile) ;; For now, run closures interpreted (lambda (x) (symbol-function x))) ;; At some point, could compile saved ;; gazonk files without loading (i.e. ;; returning interpreted code) on first pass ;; then don't compile by load -> initialize ;; on second pass. Cannot load via dlopen ;; more than 1024 files at once, and this is ;; the only relocation mechanism currently ;; available on ia64,alpha,mips,hppa ;; On first attempt, failure on initizlization of ;; acl2_gazonk3558.o (setf (symbol-function la) (lambda () nil)) ;; save-acl2 calls load-acl2, but we can't load ;; twice when initializing in reality. (setf (symbol-function 'si::save-system) ;; Restore all moved functions on save-system (lambda (x) (setf (symbol-function 'compiler::compile) ocf) (setf (symbol-function la) olf) (setf (symbol-function 'si::save-system) osf) (when si::*binary-modules* ;; Saving when a .o has been loaded is a no-no (error "Loading binary modules prior to image save in dlopen image: ~S~%" si::*binary-modules*)) (funcall osf x))) (let* ((no-save si::*binary-modules*)) ;; Don't call save-system on first pass (funcall (symbol-function sa) (list ia (list 'quote ib) ap2f (concatenate 'string (namestring (truename "")) "books/")) ;; save-acl2 nil no-save)))))))) (eval com) ;; first evaluate the command in gcl (compiler::link ;; link in the .o files with ld (remove-duplicates si::*binary-modules* :test (function equal)) ;; collected here "saved_acl2" ;; new image (format nil "~S" com) ;; run the build sequence again in this image ;; with load redirected to initialize "" nil))) (good-bye) debian/old/0000755000000000000000000000000012073642104007743 5ustar debian/old/acl2-doc.doc-base0000644000000000000000000000051511440300440012716 0ustar Document: acl2 Title: Debian ACL2 Manual Author: Matt Kaufmann,kaufmann@cs.utexas.edu and J Strother Moore,moore@cs.utexas.edu Abstract: This manual documents the ACL2 computational logic system. Section: Science/Mathematics Format: HTML Index: /usr/share/doc/acl2-doc/HTML/acl2-doc.html Files: /usr/share/doc/acl2-doc/HTML/*.html debian/old/patches.in0000644000000000000000000000177712073343077011745 0ustar --- v2-8-alpha-03-17/books/interface/emacs/acl2-interface.el 2004-03-17 05:43:50.000000000 +0000 +++ acl2-2.8/books/interface/emacs/acl2-interface.el 2004-03-23 20:11:08.000000000 +0000 @@ -28,13 +28,18 @@ ;; ---------------------------------------------------------------------- ;; 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) +;(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.el") +(load "acl2-interface-functions") ;; ---------------------------------------------------------------------- ;; Specials used by functions in interface-macros.el. debian/source/0000755000000000000000000000000011440461572010472 5ustar debian/source/format0000644000000000000000000000001411440461572011700 0ustar 3.0 (quilt) debian/acl2.dirs0000644000000000000000000000001011440300440010647 0ustar usr/bin debian/TODO0000644000000000000000000000003411440300440007641 0ustar nonstd books workshop books debian/acl2-emacs.emacsen-install0000644000000000000000000000233512074346155014110 0ustar #! /bin/sh -e # /usr/lib/emacsen-common/packages/install/acl2 # Written by Jim Van Zandt , borrowing heavily # from the install scripts for gettext by Santiago Vila # and octave by Dirk Eddelbuettel . FLAVOR=$1 PACKAGE=acl2 if [ ${FLAVOR} = emacs ]; then exit 0; fi echo install/${PACKAGE}: Handling install for emacsen flavor ${FLAVOR} #FLAVORTEST=`echo $FLAVOR | cut -c-6` #if [ ${FLAVORTEST} = xemacs ] ; then # SITEFLAG="-no-site-file" #else # SITEFLAG="--no-site-file" #fi FLAGS="${SITEFLAG} -q -batch -l path.el -f batch-byte-compile" ELDIR=/usr/share/emacs/site-lisp/${PACKAGE} ELCDIR=/usr/share/${FLAVOR}/site-lisp/${PACKAGE} # Install-info-altdir does not actually exist. # Maybe somebody will write it. if test -x /usr/sbin/install-info-altdir; then echo install/${PACKAGE}: install Info links for ${FLAVOR} install-info-altdir --quiet --section "" "" --dirname=${FLAVOR} /usr/info/${PACKAGE}.info.gz fi install -m 755 -d ${ELCDIR} cd ${ELDIR} FILES=`ls -1 *.el |grep -v ^load` cp ${FILES} ${ELCDIR} cd ${ELCDIR} cat << EOF > path.el (setq load-path (cons "." load-path) byte-compile-warnings nil) EOF ${FLAVOR} ${FLAGS} ${FILES} rm -f *.el path.el exit 0 debian/sublis_patch.lsp0000644000000000000000000000060111440300440012351 0ustar (in-package 'compiler) (defun sublis1-inline (a b c) (let ((tst (or (car (find (cadr c) *objects* :key 'cadr)) (let ((v (member (cadr c) *top-level-forms* :key 'cadr))) (and v (eq (caar v) 'sharp-comma) (cmp-eval (caddar v))))))) (or (member tst '(eq equal eql)) (error "bad test")) (wt "(check_alist(" a "),sublis1("a "," b "," (format nil "~(&~a~)))" tst)))) debian/acl2-infix.postrm.old0000644000000000000000000000020111440300440013124 0ustar #!/bin/sh set -e if [ "$1" = "remove" ] || [ "$1" = "purge" ] ; then [ "$(which texhash)" = "" ] || texhash fi #DEBHELPER# debian/acl2-emacs.emacsen-remove0000644000000000000000000000071011440300440013711 0ustar #!/bin/sh -e # /usr/lib/emacsen-common/packages/remove/acl2 FLAVOR=$1 PACKAGE=acl2 if [ ${FLAVOR} != emacs ]; then if test -x /usr/sbin/install-info-altdir; then echo remove/${PACKAGE}: removing Info links for ${FLAVOR} install-info-altdir --quiet --remove --dirname=${FLAVOR} /usr/info/acl2.info.gz fi echo remove/${PACKAGE}: purging byte-compiled files for ${FLAVOR} rm -rf /usr/share/${FLAVOR}/site-lisp/${PACKAGE} fi debian/acl2-infix.postinst.old0000644000000000000000000000011711440300440013471 0ustar #!/bin/sh set -e if [ "$1" = "configure" ] ; then texhash fi #DEBHELPER# debian/patches/0000755000000000000000000000000012213364424010616 5ustar debian/patches/fix-elementary-bounders.acl20000644000000000000000000000254012175535151016136 0ustar Description: 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.2-5) unstable; urgency=low . * (setq si::*optimize-maximum-pages* nil) in elementary-bounders.acl2 * build-dep against latest gcl Author: Camm Maguire --- 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: , Bug: Bug-Debian: http://bugs.debian.org/ Bug-Ubuntu: https://launchpad.net/bugs/ Forwarded: Reviewed-By: Last-Update: --- acl2-6.2.orig/books/tau/bounders/elementary-bounders.acl2 +++ acl2-6.2/books/tau/bounders/elementary-bounders.acl2 @@ -1,7 +1,7 @@ #+acl2-par (set-waterfall-parallelism t) - +:q #+gcl (setq si::*optimize-maximum-pages* nil) - +(lp) (certify-book "elementary-bounders") debian/patches/add-upstream-certificate-relocation-patch-to-other-events.lisp0000644000000000000000000000351012213364424024647 0ustar Description: 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.2-8) unstable; urgency=low . * Allow certification failures for 1) dlopen machines, as we cannot control the surpassed 1024 maximum dlopen limit, and 2) machines with an insufficient hard limit on data segment size (e.g. kfreebsd-i386, or any machine which cannot brk 1Gb). * add build-dep on texinfo * add upstream certificate relocation patch to other-events.lisp Author: Camm Maguire --- 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: , Bug: Bug-Debian: http://bugs.debian.org/ Bug-Ubuntu: https://launchpad.net/bugs/ Forwarded: Reviewed-By: Last-Update: --- acl2-6.2.orig/other-events.lisp +++ acl2-6.2/other-events.lisp @@ -12970,7 +12970,9 @@ certification-file (replace-string-prefix-in-tree post-alist3 old-dir (length old-dir) new-dir) - expansion-alist pcert-info cert-op ctx state)) + (replace-string-prefix-in-tree + expansion-alist old-dir (length old-dir) new-dir) + pcert-info cert-op ctx state)) (defun make-certificate-file (file portcullis post-alist1 post-alist2 expansion-alist pcert-info debian/patches/tight-memory-for-centaur-toplint0000644000000000000000000000263112076103375017105 0ustar Description: 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-3) unstable; urgency=low . * Lintian cleanups * certify centaur books with memory adjustments (lint.acl2, top.acl2) Author: Camm Maguire --- 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: , Bug: Bug-Debian: http://bugs.debian.org/ Bug-Ubuntu: https://launchpad.net/bugs/ Forwarded: Reviewed-By: Last-Update: --- /dev/null +++ acl2-6.0/books/centaur/vl/top.acl2 @@ -0,0 +1,4 @@ +(acl2::value :q) +(setq si::*optimize-maximum-pages* nil) +(acl2::lp) +(include-book "portcullis") --- /dev/null +++ acl2-6.0/books/centaur/vl/lint/lint.acl2 @@ -0,0 +1,4 @@ +(acl2::value :q) +(setq si::*optimize-maximum-pages* nil) +(acl2::lp) +(include-book "../portcullis") debian/patches/(setq-si::*optimize-maximum-pages*-nil)-in-elementary-bounders.acl20000644000000000000000000000252612174767022025112 0ustar Description: 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.2-5) unstable; urgency=low . * (setq si::*optimize-maximum-pages* nil) in elementary-bounders.acl2 * build-dep against latest gcl Author: Camm Maguire --- 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: , Bug: Bug-Debian: http://bugs.debian.org/ Bug-Ubuntu: https://launchpad.net/bugs/ Forwarded: Reviewed-By: Last-Update: --- acl2-6.2.orig/books/tau/bounders/elementary-bounders.acl2 +++ acl2-6.2/books/tau/bounders/elementary-bounders.acl2 @@ -1,4 +1,7 @@ #+acl2-par (set-waterfall-parallelism t) +#+gcl +(setq si::*optimize-maximum-pages* nil) + (certify-book "elementary-bounders") debian/patches/4.30000644000000000000000000000274312015746007011054 0ustar Description: 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 (4.3-1) unstable; urgency=low . * New upstream release Author: Camm Maguire --- 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: , Bug: Bug-Debian: http://bugs.debian.org/ Bug-Ubuntu: https://launchpad.net/bugs/ Forwarded: Reviewed-By: Last-Update: Index: acl2-5.0/acl2-fns.lisp =================================================================== --- acl2-5.0.orig/acl2-fns.lisp 2012-08-20 01:06:11.000000000 +0000 +++ acl2-5.0/acl2-fns.lisp 2012-08-24 18:45:49.000000000 +0000 @@ -1354,7 +1354,7 @@ #+gcl (cond - ((gcl-version->= 2 7 0) + (t;(gcl-version->= 2 7 0) ; It seems that GCL 2.7.0 has had problems with user-homedir-pathname in static ; versions because of how some system functions are relocated. So we define debian/patches/series0000644000000000000000000000012212213364424012026 0ustar consolidate-in-6.2 add-upstream-certificate-relocation-patch-to-other-events.lisp debian/patches/interface-from-5.00000644000000000000000000202372512072641134013754 0ustar Description: 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 --- 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: , Bug: Bug-Debian: http://bugs.debian.org/ Bug-Ubuntu: https://launchpad.net/bugs/ Forwarded: Reviewed-By: Last-Update: --- /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 '||) + 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 ')) + +(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: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 -theory.lisp. Normally this +file also loads a basic file called -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 successfull 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 ... +- BV ... EV corresponds to ... +- BE ... EE corresponds to ... +- BS ... ES corresponds to ... +- BC ... EC corresponds to ... +- +- 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 -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))) + ;;
) + (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 "Quiting 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 -init file, or may be called by +; the -theory file to override the -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 \else$$\fi} + +with the two s identical and often containing more ifmmodes. + +I happened across a solution to this problem in the Latex manual. + + \mbox{$$} + +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 ')) + +(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 :mode ) + +where is the name of a .lisp file and, in the +simplest case, 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 `.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 \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 '\051)SH +11050 63406 MT +(Undo through ...)SH +23400 XM +(\050ubt! '\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 \051\051)SH +11050 68931 MT +(Enable ...)SH +23400 XM +(\050in-theory \050enable \051\051)SH +11050 71141 MT +(Verify guards ...)SH +23400 XM +(\050verify-guards '\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 '\051)SH +11050 11896 MT +(Certify-book ...)SH +23400 XM +(\050certify-book \051)SH +11050 13001 MT +(Include-book ...)SH +23400 XM +(\050include-book \051)SH +10800 15211 MT +(Compound commands)SH +12850 16821 MT +(Expand compound command ...)SH +27000 XM +(\050puff '\051)SH +12850 17926 MT +(Expand compound command! ...)SH +27000 XM +(\050puff* '\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 nil nil :clear)SH +12850 23956 MT +(Print guard ...)SH +23400 XM +(\050table 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 '\051)SH +11050 33901 MT +(Command block ...)SH +23400 XM +(\050pcb '\051)SH +11050 35006 MT +(Full Command block ...)SH +23400 XM +(\050pcb! '\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! '\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 \051 't\051)SH +14650 69071 MT +(Unmonitor rune: ...)SH +23400 XM +(\050unmonitor '\050:definition \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 )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 )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 '\051)SH +12850 33806 MT +(Arguments)SH +23400 XM +(\050args '\051)SH +12850 34911 MT +(More)SH +23400 XM +(\050more\051)SH +12850 36016 MT +(Apropos ...)SH +23400 XM +(\050docs '\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 '\051)SH +9250 47397 MT +(Print back to)SH +23400 XM +(\050pbt '\051)SH +9250 48502 MT +(Disable)SH +23400 XM +(\050in-theory \050disable \051\051)SH +9250 49607 MT +(Enable)SH +23400 XM +(\050in-theory \050enable \051\051)SH +9250 50712 MT +(Undo)SH +23400 XM +(\050ubt ':here\051)SH +9250 51817 MT +(Undo thru)SH +23400 XM +(\050ubt '\051)SH +9250 52922 MT +(Documentation)SH +23400 XM +(\050doc '\051)SH +9250 54027 MT +(Arguments, etc)SH +23400 XM +(\050args '\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 )) +(setq interface-popup-function '(inf-acl2-send-string )) + +;; 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 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 thing)) + ((and (stringp number) + (numberp (setq number (int-to-string number)))) + (inf-acl2-send-string 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 )") + ;; ("Set element ..." "(table )") + ;; ("Set value ..." "(table nil :clear)") + ;; ("Set Guard ..." "(table nil nil :guard )") + )) + (: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" . ))))) +;; +;; (defthm foo "bar" body +;; :rule-classes (a .b) +;; :hints (("Goal" ))) + +;; 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 #<\\> 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. +;; is replaced by the command string in the menu, and +;; by the value of the computed argument (or nil) depending on +;; the arg description in the menu. +;; Example: '(inf-acl2-send-string ) + +(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 and 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 (# 236 (53 . 8) 1222667)) +;; | +;; event-start +;; (# 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 ' (subst 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 ((-map-set (make-function-name xxx "-map-set")) + (-mode-revert-fn (make-function-name xxx "-revert-fn")) + (-saved-mode-map (make-function-name xxx "-saved-map")) + (-menu-bar-name (make-function-name xxx "-menu-bar")) + (-menu-bar-remove-name (make-function-name xxx "-menu-bar-remove")) + (-popup-menu-name (make-function-name xxx "-popup-menu")) + (-keys-name (make-function-name xxx "-keys")) + (-mode-hook (make-function-name xxx "-hook")) + (-interface-hook-fn (make-function-name xxx "-interface-hook-fn")) + (-prefix-menu (concat (symbol-name xxx) "-menu-")) + (-prefix-popup (concat (symbol-name xxx) "-popup-")) + (-prefix-keys (concat (symbol-name xxx) "-keys-"))) + (if (equal -popup-menu-name popup-menu) + (setq -popup-menu-name (make-function-name -popup-menu-name "-2"))) + (acl2-substitute (list (cons '-map-name mode-map-name) + (cons '-menu-bar menu-bar) + (cons '-menu-bar-remove menu-bar-remove) + (cons '-popup-menu popup-menu) + (cons '-keys keys) + (cons '-menu-bar-name -menu-bar-name) + (cons '-popup-menu-name -popup-menu-name) + (cons '-menu-bar-remove-name -menu-bar-remove-name) + (cons '-keys-name -keys-name) + (cons '-map-set -map-set) + (cons '-mode-revert-fn -mode-revert-fn) + (cons '-saved-mode-map -saved-mode-map) + (cons '-mode-hook -mode-hook) + (cons '-interface-hook-fn -interface-hook-fn) + (cons '-prefix-menu -prefix-menu) + (cons '-prefix-popup -prefix-popup) + (cons '-prefix-keys -prefix-keys)) + '(progn + + (defconst -map-set nil) + + (defconst -menu-bar-name -menu-bar) + (defconst -menu-bar-remove-name -menu-bar-remove) + + (defun -mode-revert-fn () + (setq -map-name -saved-mode-map) + (setq -map-set nil)) + + (defun -interface-hook-fn () + (cond ((and (boundp '-map-name) (not -map-set)) + (setq -saved-mode-map (copy-keymap -map-name)) + (remove-from-menu-bar -menu-bar-remove -map-name) + (extend-menu-bar '-map-name [menu-bar] -menu-bar-name + -prefix-menu) + (define-popup-menu '-map-name '-popup-menu-name + -popup-menu) + (define-mode-keys '-map-name -map-name -keys) + (setq -map-set t)))) + + (defconst -mode-hook + (if (boundp '-mode-hook) + (extend-hook -mode-hook '-interface-hook-fn) + '(-interface-hook-fn))) + + (-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 `.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 + +@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 + +@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 + +@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 + +@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 + +@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 + +@begin(menu) +Events@begin(menu) + Recent events @\(pbt '(:here -10)) + Print back through ...@\(pbt ) + Undo @\(ubt ':here) + Oops @\(oops) + Undo through ... @\(ubt ') + Undo through ... @\(ubt! ') + + Load file ... @\(cl2-load-file) + + Disable ...@\(in-theory (disable )) + Enable ... @\(in-theory (enable )) + + Verify guards ... @\(verify-guards ') + Verify termination ... @\(verify-guards ') + + Certify-book ... @\(certify-book ) + Include-book ... @\(include-book ) + +Compound commands @begin(menu) + Expand compound command ... @\(puff ') + Expand compound command! ... @\(puff* ') +@end(menu) + +Table@begin(menu) + Print value ... @\(table symbol) + Clear ... @\(table nil nil :clear + Print guard ... @\(table nil nil :guard) +@end(menu) +@end(menu) + +Print@begin(menu) + + Event ... @\(pe 'event) + Event! ... @\(pe! 'event) + Back through ... @\(pbt 'event) + + Command ... @\(pc ') + Command block ... @\(pcb ') + Full Command block ... @\(pcb! ') + + 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! ') + + 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 ) 't) + Unmonitor rune: ... @\(unmonitor '(:definition ))@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 + 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 @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 ') + Arguments @\(args ') + More @\(more) + Apropos ... @\(docs ') + Info @\(cl2-info) + Tutorial @\(acl2-info-tutorial) + Release Notes @\(cl2-info-release-notes)@end(menu) + +@end(menu) +@end(menu) + + + +@subsubsection + +@begin(menu) + Recent events @\(pbt '(:here -10)) + Print Event @\(pe ') + Print back to @\(pbt ') + Disable @\(in-theory (disable )) + Enable @\(in-theory (enable )) + Undo @\(ubt ':here) + Undo thru @\(ubt ') + Documentation @\(doc ') + Arguments, etc @\(args ') + Verify @\Take clicked on form into interactive prover. +@end(menu) + +@subsubsection + +@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 +;; 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 +;;; bindings, which is not allowed by the gnumacs standard. + +;;; "This function binds many inferior-acl2 commands to C-c bindings, +;;;where they are more accessible. C-c 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 `.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 ) + Undo (ubt ':here) + Oops (oops) + Undo through ... (ubt ') + Undo through ... (ubt! ') + + Load file ... (cl2-load-file) + + Disable ... (in-theory (disable )) + Enable ... (in-theory (enable )) + + Verify guards ... (verify-guards ') + Verify termination ... (verify-guards ') + + Certify-book ... (certify-book ) + Include-book ... (include-book ) + + Compound commands + + Expand compound command ... (puff ') + Expand compound command! ... (puff* ') + + Table + + Print value ... (table symbol) + Clear ... (table nil nil :clear + Print guard ... (table nil nil :guard) + + Print + + Event ... (pe 'event) + Event! ... (pe! 'event) + Back through ... (pbt 'event) + + Command ... (pc ') + Command block ... (pcb ') + Full Command block ... (pcb! ') + + 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! ') + + 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 ) 't) + Unmonitor rune: ... (unmonitor '(:definition )) + + Commands + + Abort to ACL2 top-level #. + Term being rewritten :target + Substitution making :lhs equal :target :unify-subst + Hypotheses :hyps + Ith hypothesis ... :hyp + 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 + + 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 ') + Arguments (args ') + More (more) + Apropos ... (docs ') + Release Notes (cl2-info-release-notes) + + + +3.4-B INFERIOR ACL2 POPUP MENU + + Recent events (pbt '(:here -10)) + Print Event (pe ') + Print back to (pbt ') + Disable (in-theory (disable )) + Enable (in-theory (enable )) + Undo (ubt ':here) + Undo thru (ubt ') + Documentation (doc ') + Arguments, etc (args ') + 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) debian/patches/debian-changes-4.1-50000644000000000000000000000255711702660553014050 0ustar Description: Upstream changes introduced in version 4.1-5 This patch has been created by dpkg-source during the package build. Here's the last changelog entry, hopefully it gives details on why those changes were made: . acl2 (4.1-5) unstable; urgency=low . * build depend on latest gcl * turn off si::*optimize-maximum-pages* in reverse-by-separation.acl2 * remove unnecessary patch from serialize-tests.lisp . The person named in the Author field signed this changelog entry. Author: Camm Maguire --- 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: , Bug: Bug-Debian: http://bugs.debian.org/ Bug-Ubuntu: https://launchpad.net/bugs/ Forwarded: Reviewed-By: Last-Update: --- acl2-4.1.orig/books/misc/misc2/reverse-by-separation.acl2 +++ acl2-4.1/books/misc/misc2/reverse-by-separation.acl2 @@ -1,2 +1,5 @@ +(acl2::value :q) +(setq si:*optimize-maximum-pages* nil) +(acl2::lp) (include-book "coi/bags/top" :dir :system) (certify-book "reverse-by-separation" 1) debian/patches/clean-interface0000644000000000000000000000364112072641410013561 0ustar Description: 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 --- 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: , Bug: Bug-Debian: http://bugs.debian.org/ Bug-Ubuntu: https://launchpad.net/bugs/ Forwarded: Reviewed-By: Last-Update: --- acl2-6.0.orig/interface/emacs/acl2-interface.el +++ acl2-6.0/interface/emacs/acl2-interface.el @@ -28,18 +28,13 @@ ;; ---------------------------------------------------------------------- ;; 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) +(load "inf-acl2.el") ;(require 'inf-acl2) +(load "mfm-acl2.el") ;(require 'mfm-acl2) +(load "interface-macros.el") ;(require 'interface-macros) (update-mode-menu-alist *acl2-user-map-interface*) -;(load "acl2-interface-functions.el") -(load "acl2-interface-functions") +(load "acl2-interface-functions.el") ;; ---------------------------------------------------------------------- ;; Specials used by functions in interface-macros.el. debian/patches/4.3a0000644000000000000000000000305211703105233011200 0ustar Description: 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 (4.3-1) unstable; urgency=low . * New upstream release Author: Camm Maguire --- 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: , Bug: Bug-Debian: http://bugs.debian.org/ Bug-Ubuntu: https://launchpad.net/bugs/ Forwarded: Reviewed-By: Last-Update: --- acl2-4.3.orig/GNUmakefile +++ acl2-4.3/GNUmakefile @@ -966,7 +966,7 @@ arch: full init move-large regression-fr mini-proveall: @rm -rf mini-proveall.out @echo '(value :q) (lp) (mini-proveall)' | ./${PREFIXsaved_acl2} > mini-proveall.out - @(grep '^ ORDERED-SYMBOL-ALISTP-REMOVE-FIRST-PAIR-TEST' mini-proveall.out > /dev/null) || \ + @(grep '^ ORDERED-SYMBOL-ALISTP-DELETE-ASSOC-EQ-TEST' mini-proveall.out > /dev/null) || \ (echo 'Mini-proveall failed!' ; ls -l ./${PREFIXsaved_acl2}; cat mini-proveall.out ; exit 1) @echo 'Mini-proveall passed.' debian/patches/consolidate-in-6.20000644000000000000000000000503612167610600013756 0ustar Description: 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.2-1) UNRELEASED; urgency=low . * New upstream release Author: Camm Maguire --- 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: , Bug: Bug-Debian: http://bugs.debian.org/ Bug-Ubuntu: https://launchpad.net/bugs/ Forwarded: Reviewed-By: Last-Update: --- acl2-6.2.orig/acl2-fns.lisp +++ acl2-6.2/acl2-fns.lisp @@ -1371,7 +1371,7 @@ notation causes an error and (b) the use #+gcl (cond - ((gcl-version->= 2 7 0) + (t;(gcl-version->= 2 7 0) ; It seems that GCL 2.7.0 has had problems with user-homedir-pathname in static ; versions because of how some system functions are relocated. So we define --- acl2-6.2.orig/books/misc/misc2/reverse-by-separation.acl2 +++ acl2-6.2/books/misc/misc2/reverse-by-separation.acl2 @@ -1,3 +1,6 @@ +(acl2::value :q) +(setq si:*optimize-maximum-pages* nil) +(acl2::lp) (include-book "coi/bags/top" :dir :system) #+acl2-par --- acl2-6.2.orig/books/interface/emacs/acl2-interface.el +++ acl2-6.2/books/interface/emacs/acl2-interface.el @@ -28,13 +28,18 @@ ;; ---------------------------------------------------------------------- ;; 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) +;(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.el") +(load "acl2-interface-functions") ;; ---------------------------------------------------------------------- ;; Specials used by functions in interface-macros.el. debian/patches/patches.in-replacement0000644000000000000000000000365512073642047015107 0ustar Description: 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 --- 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: , Bug: Bug-Debian: http://bugs.debian.org/ Bug-Ubuntu: https://launchpad.net/bugs/ Forwarded: Reviewed-By: Last-Update: --- acl2-6.0.orig/books/interface/emacs/acl2-interface.el +++ acl2-6.0/books/interface/emacs/acl2-interface.el @@ -28,13 +28,18 @@ ;; ---------------------------------------------------------------------- ;; 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) +;(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.el") +(load "acl2-interface-functions") ;; ---------------------------------------------------------------------- ;; Specials used by functions in interface-macros.el. debian/acl2.manpages0000644000000000000000000000001611440300440011507 0ustar debian/acl2.1 debian/rules0000755000000000000000000002743612227246570010271 0ustar #!/usr/bin/make -f # Sample debian/rules that uses debhelper. # GNU copyright 1997 by Joey Hess. # # This version is for a hypothetical package that builds an # architecture-dependant package, as well as an architecture-independent # package. # Uncomment this to turn on verbose mode. #export DH_VERBOSE=1 # This is the debhelper compatability version to use. #export DH_COMPAT=4 # This has to be exported to make some magic below work. export DH_OPTIONS PN:=acl2 VR:=$(shell awk '{if (i) next;i=1;a=$$2;gsub("[()]","",a);split(a,A,"-");print A[1];}' debian/changelog) PD:=$(PN)-$(VR) NO_STRIP:= # ifeq ($(DEB_BUILD_ARCH),powerpc) # NO_STRIP:=--exclude=saved_acl2 # endif books/workshops: mkdir $@ #init.lsp.ori: # [ -e $@ ] || mv init.lsp $@ DLOPEN_T:=debian/dlopen.lisp #init.lsp.ori #ifeq ($(DEB_BUILD_ARCH),ia64) #DLOPEN?=$(DLOPEN_T) #endif #ifeq ($(DEB_BUILD_ARCH),alpha) #DLOPEN?=$(DLOPEN_T) #endif #ifeq ($(DEB_BUILD_ARCH),mips) #DLOPEN?=$(DLOPEN_T) #endif #ifeq ($(DEB_BUILD_ARCH),mipsel) #DLOPEN?=$(DLOPEN_T) #endif #ifeq ($(DEB_BUILD_ARCH),hppa) #DLOPEN?=$(DLOPEN_T) #endif debian/dlopen.lisp: debian/dlopen.lisp.in cat $< | sed "s,@VR@,$(VR),g" > $@ debian/acl2-emacs.emacsen-startup: debian/acl2-emacs.emacsen-startup.in cat $< | sed "s,@VR@,$(VR),g" > $@ saved_acl2: $(DLOPEN_T) #debian/patches_applied # echo '(progn (load "debian/sublis_patch.lsp")(si::save-system "pgcl"))' | gcl gcl -batch -eval "(bye #-native-reloc 1)" || \ (gcl -batch -eval '(load "debian/dlopen.lisp")' && $(MAKE) do_saved) gcl -batch -eval "(bye #+native-reloc 1)" || $(MAKE) LISP=gcl mv *$@.gcl $@ saved_acl2.c: saved_acl2 echo "(f-put-global 'old-certification-dir \"$$(pwd)/books\" state)" \ "(f-put-global 'new-certification-dir \"/usr/share/$(PD)/books\" state)" \ ":q #-native-reloc (setq si::*multiply-stacks* 4) :q (in-package :acl2) " \ "#+(or sparc sparc64)(progn (si::sgc-on nil) (fmakunbound 'si::sgc-on))" \ "(save-exec \"$@\" \"Modified to produce final certification files\")" | ./$< mv $@.gcl $@ debian/mini-proveall.out: saved_acl2 HOME=$$(pwd) $(MAKE) mini-proveall mv $(@F) $@ books/short-test.log: saved_acl2.c cp saved_acl2 saved_acl2.ori HOME=$$(pwd) $(MAKE) certify-books-short cp saved_acl2.ori saved_acl2 # tail -f --pid=$$j --retry $@ $$(find books -name "*.lisp" | sed 's,\.lisp$$,.out,1') & \ debian/test.log: saved_acl2.c mv saved_acl2 saved_acl2.ori cp $< saved_acl2 BUILDDIR="$$(dirname $$(pwd))" \ FINALDIR="/usr/share/$(PD)" \ HOME=$$(pwd) \ $(MAKE) certify-books >$@ 2>&1 & j=$$! ; \ while sleep 1800; do echo Tick; done & k=$$! ; tail -f debian/test.log & l=$! ; \ wait $$j ; kill $$k $$l [ -f $@ ] && ! fgrep '**' $@ || echo FULL TEST FAILS for i in $$(find books -name "*.out"); do \ if ! [ -e $${i%out}cert ] ; then \ echo $$i ; \ cat $$i ; \ fi ; \ done mv saved_acl2.ori saved_acl2 [ -f $@ ] && ( ! fgrep '**' $@ || \ gcl -batch -eval "(bye #+native-reloc 1)" || \ [ $$(ulimit -d -H | sed 's,unlimited,1000000,g') -lt 1000000 ] ) books/interface/infix/Makefile: books/interface/infix/makefile sed -e "s,^DIR = .*,DIR = $$(pwd)/books/interface/infix,1" \ -e "s,^LISP = .*,LISP = $$(pwd)/saved_acl2,1" $< > $@ infix-stamp: books/interface/infix/Makefile saved_acl2 cd books/interface/infix && make -f Makefile compile cd books/interface/infix && make -f Makefile example # cd books/interface/infix && make -f Makefile events touch $@ doc/TEX/acl2-book.ps.gz: saved_acl2 HOME=$$(pwd) $(MAKE) DOC rm -f doc/HTML/LICENSE find doc -empty -exec rm {} \; build: build-arch build-indep build-arch: build-stamp build-indep: build-stamp build-stamp: debian/mini-proveall.out debian/test.log infix-stamp doc/TEX/acl2-book.ps.gz dh_testdir # $(MAKE) touch build-stamp infix_clean: books/interface/infix/Makefile rm -f infix-stamp cd books/interface/infix && make -f Makefile clean rm -f books/interface/infix/Makefile debian/dpatches: debian/patches.in debian/rules debian/patches_unapplied cat $< | sed -e "s,@BDIR@,$$(pwd),1" -e "s,@DDIR@,/usr/share/$(PD),1" >$@ debian/patches_applied: debian/dpatches ! [ -e debian/patches_unapplied ] || \ (patch -p1 < $< && rm -f debian/patches_unapplied) touch $@ debian/patches_unapplied: ! [ -e debian/patches_applied ] || ! [ -e debian/dpatches ] || \ (patch -p1 -R < debian/dpatches && rm -f debian/patches_applied) touch $@ INSTALLS:=$(addprefix debian/,$(addsuffix .install,acl2 acl2-source acl2-emacs acl2-doc acl2-books acl2-books-source acl2-books-certs acl2-infix acl2-infix-source)) LINKS:=$(addprefix debian/,$(addsuffix .links,acl2 acl2-books acl2-infix)) IFILES:=$(INSTALLS) $(shell ls -1 debian/*.examples debian/*.docs) debian/README.Debian: debian/README.Debian.in $(IFILES) awk '/@PLIST@/ {exit 0} {print}' $< >$@ for i in $(filter %.install,$^); do\ awk '/^debian\// {next} {sub(".final$$","",$$1);$$2="/" $$2;print $$0 " " p}' \ p=$$(basename $${i%.install}) $$i >>$@ ; done for i in $(filter %.info,$^); do\ awk '/^debian\// {next} {print $$0 " /usr/share/info " p}' p=$$(basename $${i%.info}) $$i >>$@ ; done for i in $(filter %.examples,$^); do\ awk '/^debian\// {next} {print $$0 " /usr/share/doc/" p "/examples " p}' \ p=$$(basename $${i%.examples}) $$i >>$@ ; done for i in $(filter %.docs,$^); do\ awk '/^debian\// {next} {print $$0 " /usr/share/doc/" p " " p}' p=$$(basename $${i%.docs}) $$i >>$@ ; done awk '/@PLIST@/ {i=1;next} {if (i) print}' $< >>$@ clean: books/workshops infix_clean #debian/patches_unapplied dh_testdir dh_testroot rm -f build-stamp $(MAKE) clean $(MAKE) clean-books find books -name "*.final" -exec rm {} \; rm -f saved_acl2 init_nsaved1_acl2.lsp worklispext rm -f debian/mini-proveall.out books/short-test.log debian/test.log # ! [ -e init.lsp.ori ] || mv init.lsp.ori init.lsp rm -f foo.lsp nsaved_acl2 for i in data c h ; do \ for j in $$(find -name "*.$$i") ; do\ k=$$(echo $$j | sed "s,\.$$i$$,,1") ;\ ! [ -e $$k.lisp ] || rm $$j ; \ done ; \ done rm -f books/bdd/benchmarks.data acl2r.lisp tmp rmdir $< rm -f debian/dpatches $(INSTALLS) $(LINKS) debian/README.Debian saved_acl2* rm -f debian/dlopen.lisp debian/acl2-emacs.emacsen-startup rm -f debian/acl2.sh pgcl books/Makefile-tmp books/coi/gensym/gensym.out rm -f books/coi/gensym/Makefile-deps books/coi/gensym/workxxx.gensym rm -rf doc/HTML-old doc/EMACS-old doc/acl2-wc.txt rm -f books/centaur/bitops/bitsets-opt-raw.o books/centaur/vl/util/gc-raw.o \ books/centaur/misc/tshell-raw.o books/centaur/vl/Makefile-tmp dh_clean -XTAGS debian/acl2-infix.install:: find books/interface/infix -name "*.o" | awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/lib/$(PD)/%s\n",$$1,a);}' >>$@ find books/interface/infix -name "*.sty" | \ awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/share/texmf/tex/latex\n",$$1);}' >>$@ debian/acl2-infix-source.install:: find books/interface/infix -name "*.lisp" | awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/lib/$(PD)/%s\n",$$1,a);}' >>$@ debian/acl2-emacs.install:: find books/interface/emacs -name "*.el" | awk '{printf("%s usr/share/emacs/site-lisp/$(PN)\n",$$1);}' >>$@ find emacs -name "*.el" | awk '{printf("%s usr/share/emacs/site-lisp/$(PN)\n",$$1);}' >>$@ debian/acl2.install:: echo debian/acl2.sh usr/bin >>$@ echo saved_acl2 usr/lib/$(PD) >>$@ debian/acl2-books.install:: find books -name "*.o" | grep -v interface/ | awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/lib/$(PD)/%s\n",$$1,a);}' >>$@ debian/acl2-source.install:: find * -name "*.lisp" -maxdepth 0 | grep -v TMP1.lisp | awk '{printf("%s usr/share/$(PD)\n",$$1);}' >$@ find * -name "TAGS" -maxdepth 0 | awk '{printf("%s usr/share/$(PD)\n",$$1);}' >>$@ debian/acl2-books-certs.install:: find books -name "*.cert" | grep -v fix-cert/moved | grep -v system/pcert | \ awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s.final usr/share/$(PD)/%s\n",$$1,a);}' >>$@ find books -name "*.pcert0.final" | \ awk '{a=$$1;sub(".pcert0.final",".cert",a);printf("%s usr/share/$(PD)/%s\n",$$1,a);}' >>$@ debian/acl2-books-source.install:: find books -name "*.lisp" | awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/share/$(PD)/%s\n",$$1,a);}' >>$@ find books -name "*.acl2" | awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/share/$(PD)/%s\n",$$1,a);}' >>$@ find books/bdd -name "bit-vector-reader.lsp" | awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/share/$(PD)/%s\n",$$1,a);}' >>$@ debian/acl2-doc.install:: echo doc usr/share/doc/acl2-doc >$@ find books -name "README*" | \ awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/share/doc/$(PN)-doc/%s\n",$$1,a);}' >>$@ find books/textbook -name "*.txt" | \ awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/share/doc/$(PN)-doc/%s\n",$$1,a);}' >>$@ find books/textbook -name "*.html" | \ awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/share/doc/$(PN)-doc/%s\n",$$1,a);}' >>$@ find books/bdd/be/ -type f | awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/share/doc/$(PN)-doc/%s\n",$$1,a);}' >>$@ find books/misc -name "simplify-defuns.txt" | \ awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/share/doc/$(PN)-doc/%s\n",$$1,a);}' >>$@ find books/interface/infix -name "README*" | \ awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/share/doc/$(PN)-doc/%s\n",$$1,a);}' >>$@ find books/interface/infix -name "*.ps" | \ awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/share/doc/$(PN)-doc/%s\n",$$1,a);}' >>$@ find books/interface/infix -name "*.dvi" | \ awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/share/doc/$(PN)-doc/%s\n",$$1,a);}' >>$@ find books/interface/emacs -name "README*" | \ awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/share/doc/$(PN)-doc/%s\n",$$1,a);}' >>$@ find books/arithmetic-2/pass1/arithmetic-axioms.txt | \ awk '{a=$$1;sub("/[^/]*$$","",a);printf("%s usr/share/doc/$(PN)-doc/%s\n",$$1,a);}' >>$@ debian/acl2.links:: echo usr/lib/$(PD)/saved_acl2 usr/share/$(PD)/saved_acl2 >$@ debian/acl2-books.links:: find books -name "*.o" | grep -v interface/ | awk '{printf("usr/lib/$(PD)/%s usr/share/$(PD)/%s\n",$$1,$$1);}' >>$@ debian/acl2-infix.links:: find books/interface/infix -name "*.o" | awk '{printf("usr/lib/$(PD)/%s usr/share/$(PD)/%s\n",$$1,$$1);}' >>$@ debian/acl2.sh: echo "#!/bin/bash" >$@ echo >>$@ echo "export ACL2_SYSTEM_BOOKS=/usr/share/$(PD)/books" >>$@ echo "exec /usr/lib/$(PD)/saved_acl2 -dir /usr/share/$(PD)" >>$@ chmod 755 $@ install: DH_OPTIONS= install: build $(INSTALLS) $(LINKS) debian/acl2.sh debian/acl2-emacs.emacsen-startup debian/README.Debian dh_testdir dh_testroot dh_prep -XTAGS dh_installdirs dh_install for i in $$(find debian -name "*.final"); do mv $$i $${i%.final} ; done find debian/acl2-source -name "*.lisp" -type f -exec chmod 444 {} \; find debian/acl2-source -name "*.acl2" -type f -exec chmod 444 {} \; find debian/acl2-source -name "*.lsp" -type f -exec chmod 444 {} \; find debian/acl2-books-source -name "*.lisp" -type f -exec chmod 444 {} \; find debian/acl2-books-source -name "*.acl2" -type f -exec chmod 444 {} \; find debian/acl2-books-source -name "*.lsp" -type f -exec chmod 444 {} \; mv debian/acl2/usr/bin/acl2.sh debian/acl2/usr/bin/acl2 binary-indep: DH_OPTIONS:=-i binary-indep: build install dh_testdir dh_testroot dh_installdocs dh_installexamples dh_installmenu dh_installemacsen dh_installtex -p acl2-infix dh_installcron DH_OPTIONS= dh_installinfo -p acl2-doc $$(find doc/EMACS -name "*.info*") dh_installchangelogs dh_link dh_compress dh_fixperms dh_installdeb dh_gencontrol dh_md5sums dh_builddeb binary-arch: DH_OPTIONS=-a binary-arch: build install dh_testdir dh_testroot dh_installdocs dh_installexamples dh_installmenu dh_installemacsen dh_installcron dh_installman dh_installinfo dh_installchangelogs dh_strip $(NO_STRIP) dh_link dh_compress dh_fixperms dh_installdeb dh_shlibdeps dh_gencontrol dh_md5sums dh_builddeb binary: binary-indep binary-arch .PHONY: build build-arch build-indep clean binary-indep binary-arch binary install debian/control0000644000000000000000000001070712230256630010575 0ustar Source: acl2 Section: math Priority: optional Maintainer: Camm Maguire Build-Depends: gcl ( >= 2.6.9-12 ), libgmp3-dev, libreadline-dev, emacs24 | emacsen, debhelper ( >= 5 ), texlive-latex-recommended, libxmu-dev, libxaw7-dev, time, tex-common, texinfo Standards-Version: 3.9.4 Package: acl2 Architecture: any Depends: ${shlibs:Depends}, ${misc:Depends} Recommends: acl2-source, acl2-books Suggests: acl2-emacs Description: Computational Logic for Applicative Common Lisp: main binary ACL2 is both a programming language in which you can model computer systems and a tool to help you prove properties of those models. . This package contains the base ACL2 binary. Package: acl2-source Architecture: all Conflicts: acl2 (<= 2.7-9) Replaces: acl2 (<= 2.7-9) Depends: ${misc:Depends} Description: Computational Logic for Applicative Common Lisp: source files ACL2 is both a programming language in which you can model computer systems and a tool to help you prove properties of those models. . This package contains the lisp source files to the main ACL2 binary. Package: acl2-emacs Architecture: all Depends: acl2 (>= ${source:Version}), emacs24 | emacsen, ${misc:Depends} Conflicts: acl2 (<= 2.7-9) Replaces: acl2 (<= 2.7-9) Description: Computational Logic for Applicative Common Lisp: emacs interface ACL2 is both a programming language in which you can model computer systems and a tool to help you prove properties of those models. . This package contains an emacs interface to ACL2. Package: acl2-infix Architecture: any Recommends: acl2-infix-source (= ${source:Version}) Depends: acl2 (= ${binary:Version}), texlive-latex-recommended, ${misc:Depends} Conflicts: acl2 (<= 2.7-9) Replaces: acl2 (<= 2.7-9) Description: Computational Logic for Applicative Common Lisp: infix interface ACL2 is both a programming language in which you can model computer systems and a tool to help you prove properties of those models. . This package contains utilities and libraries to access ACL2 via an infix notation similar to that used in many non-lisp programming languages. Package: acl2-infix-source Architecture: all Depends: ${misc:Depends} Conflicts: acl2 (<= 2.7-9) Replaces: acl2 (<= 2.7-9) Description: Computational Logic for Applicative Common Lisp: infix source ACL2 is both a programming language in which you can model computer systems and a tool to help you prove properties of those models. . This package contains the source files to the infix interface to ACL2. Package: acl2-books Architecture: any Depends: acl2 (= ${binary:Version}), acl2-books-certs (= ${source:Version}), acl2-books-source (= ${source:Version}), ${misc:Depends} Conflicts: acl2 (<= 2.7-9) Replaces: acl2 (<= 2.7-9) Description: Computational Logic for Applicative Common Lisp: compiled libraries ACL2 is both a programming language in which you can model computer systems and a tool to help you prove properties of those models. . This package contains numerous precompiled and precertified libraries for use in proving theorems with ACL2. Serious users will no doubt want to install this package. Package: acl2-books-source Architecture: all Depends: acl2 (>= ${source:Version}), ${misc:Depends} Conflicts: acl2 (<= 2.7-9) Replaces: acl2 (<= 2.7-9) Description: Computational Logic for Applicative Common Lisp: library sources ACL2 is both a programming language in which you can model computer systems and a tool to help you prove properties of those models. . This package contains source lisp files to the compiled libraries supplied in the ACL2-books package. Package: acl2-books-certs Architecture: all Depends: acl2 (>= ${source:Version}), ${misc:Depends} Conflicts: acl2 (<= 2.7-9) Replaces: acl2 (<= 2.7-9) Description: Computational Logic for Applicative Common Lisp: library certificates ACL2 is both a programming language in which you can model computer systems and a tool to help you prove properties of those models. . This file contains certification records for the various precompiled libraries supplied in the ACL2-books package. ACL2 essentially requires that all included books be certified before use. Package: acl2-doc Depends: ${misc:Depends}, dpkg (>= 1.15.4) | install-info Architecture: all Section: doc Description: Computational Logic for Applicative Common Lisp: documentation ACL2 is both a programming language in which you can model computer systems and a tool to help you prove properties of those models. . This package contains the documentation for ACL2. debian/watch0000644000000000000000000000044711440300440010212 0ustar version=2 # Example watch control file for uscan # Rename this file to "watch" and then you can run the "uscan" command # to check for upstream updates and more. # Site Directory Pattern Version Script opts=pasv ftp://ftp.cs.utexas.edu/pub/moore/acl2/ acl2-([0-9.]*)\.tar\.gz debian uupdate debian/acl2-infix.examples0000644000000000000000000000003612073623104012657 0ustar books/interface/infix/doinfix debian/acl2.docs0000644000000000000000000000005111440300440010643 0ustar debian/mini-proveall.out debian/test.log debian/acl2.10000644000000000000000000000251111440300440010056 0ustar .\" Hey, EMACS: -*- nroff -*- .\" First parameter, NAME, should be all caps .\" Second parameter, SECTION, should be 1-8, maybe w/ subsection .\" other parameters are allowed: see man(7), man(1) .TH ACL2 1 "October 26, 2002" .\" Please adjust this date whenever revising the manpage. .\" .\" Some roff macros, for reference: .\" .nh disable hyphenation .\" .hy enable hyphenation .\" .ad l left justify .\" .ad b justify to both left and right margins .\" .nf disable filling .\" .fi enable filling .\" .br insert line break .\" .sp insert n+1 empty lines .\" for manpage-specific macros, see man(7) .SH NAME acl2 \- A Computational Logic .SH SYNOPSIS .B acl2 .SH DESCRIPTION This manual page documents briefly the .B acl2 command. This manual page was written for the Debian GNU/Linux distribution because the original program does not have a manual page. Instead, it has documentation in the GNU Info format as well as in html format. These are included in the acl2-doc package. The documentation can also be found at the project's website, http://www.cs.utexas.edu/users/moore/acl2, both in html form and in postscript. .SH AUTHOR This manual page was written by Camm Maguire, , for the Debian GNU/Linux system (but may be used by others). debian/acl2-emacs.emacsen-startup.in0000644000000000000000000000220311440300440014522 0ustar ;; -*-emacs-lisp-*- ;; ;; Emacs startup file for the Debian GNU/Linux acl2 package ;; ;; Originally contributed by Nils Naumann ;; Modified by Dirk Eddelbuettel ;; Adapted for dh-make by Jim Van Zandt ;; The acl2 package follows the Debian/GNU Linux 'emacsen' policy and ;; byte-compiles its elisp files for each 'emacs flavor' (emacs19, ;; xemacs19, emacs20, xemacs20...). The compiled code is then ;; installed in a subdirectory of the respective site-lisp directory. ;; We have to add this to the load-path: (setq load-path (cons (concat "/usr/share/" (symbol-name debian-emacs-flavor) "/site-lisp/acl2") load-path )) (autoload 'run-acl2 "top-start-inferior-acl2" "Open communication between acl2 running in shell and prooftree." t) (defvar *acl2-interface-dir* "/usr/share/emacs/site-lisp/acl2/") ;(when (boundp 'tags-table-list);FIXME xemacs ; (setq tags-table-list (cons "/usr/share/acl2-@VR@" tags-table-list))) (autoload 'start-proof-tree (concat *acl2-interface-dir* "top-start-shell-acl2") "Enable proof tree logging in a prooftree buffer." t) debian/copyright0000644000000000000000000000767612074067762011154 0ustar This package was debianized by Camm Maguire on Sat, 26 Oct 2002 11:58:58 -0400. It was downloaded from ftp://ftp.cs.utexas.edu:/pub/moore/acl2/v2-8/ Upstream Authors: Matt Kaufmann,kaufmann@cs.utexas.edu (main program) J Strother Moore,moore@cs.utexas.edu (main program) University of Texas at Austin (books, partial) Computational Logic, Inc.,mksmith@acm.org,msmith17@austin.rr.com (books, partial) John R. Cowles, University of Wyoming (books, partial) Bishop Brock and J Strother Moore (books, partial) Panagiotis Manolios and J Strother Moore (books, partial) Georgia Institute of Technology (books, partial) Jared Davis,jared@cs.utexas.edu (books, partial) Panagiotis Manolios,manolios@cc.gatech.edu (books, partial) Daron Vroon,vroon@cc.gatech.edu (books, partial) Matt Kaufmann,kaufmann@cs.utexas.edu (books, partial) Copyright: All files in acl2_6.0.orig.tar.gz, (e.g. all sub-directories outside of "books/"): Copyright (c) 2012, Regents of the University of Texas All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: o Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. o Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. o Neither the name of the University of Texas, Austin nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. All files in acl2_6.0.orig-books.tar.gz, (e.g. the contents of the "books/" sub-directory): GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. On Debian GNU/Linux systems, the complete text of the GNU General Public License Version 2 can be found in `/usr/share/common-licenses/GPL-2'. debian/.pc/0000755000000000000000000000000012167600124007645 5ustar debian/.pc/.version0000644000000000000000000000000212167600124011323 0ustar 2 debian/.pc/.quilt_patches0000644000000000000000000000001012167600124012502 0ustar patches debian/.pc/.quilt_series0000644000000000000000000000000712167600124012353 0ustar series debian/acl2-customization.lisp0000644000000000000000000000022611440300440013574 0ustar (f-put-global 'old-certification-dir "/fix/t1/camm/debian/acl2/acl2-2.9.3" state) (f-put-global 'new-certification-dir "/usr/share/acl2-2.9.3" state) debian/README.Debian.in0000644000000000000000000000467211440300440011633 0ustar ACL2 for Debian --------------- This is a binary distribution of ACL2, as opposed to ACL2(r), the modification of the former to use certain non-standard analyses in the source. The ACL2 homepage points to two related packages which are not (yet) included in Debian -- the 'workshops' and 'nonstd' packages. Users who wish to compile these sources are advised to retrieve and build the Debian source package as follows: apt-get -q -b source acl2 You will need to ensure that the build-dependencies, as listed at the head of the file debian/control in the retrieved source tree, are installed as well. Next, retrieve and unpack the auxiliary sources into place and compile them as explained in the upstream documentation provided in the source tree. The binary package has been designed for the end-user, as is typical with all Debian binary packages, and not for the user who wants to compile related software, who should rather retrieve the source package as described above. Several files needed for building workshops and nonstd are therefore missing from the binary package distribution. If you feel Debian binary packages of workshops and or nonstd would be helpful, please send me an email to this effect. The upstream authors of ACL2 felt the need would be slight at best. As ACL2 is not typically installed into a directory tree other than that in which is was compiled, the directory layout in this binary package may be unfamiliar to experienced ACL2 users. In consultation with the original authors, we have attempted to select a layout for the binary distribution which would both conform to Debian policy as well as the spirit of the ACL2 source tree. It has been requested that the Debian ACL2 package maintain a table of source and binary file locations. This is included here below. Any files in the Debian package(s) not in this list are Debian specific utilities/scripts used in package maintenance. The first entry on each line is the location in the source tree. Where a directory is specified here, the entire directory has been mapped to its new location. The second entry on the line is the new location once the acl2 packages have been installed, and the last entry is the package name containing the file or directory. ----------------------------------------------------------------------------- @PLIST@ ----------------------------------------------------------------------------- -- Camm Maguire , Tue Feb 3 22:14:38 2004