What is it? =========== This file is set of patches for the 01nov91 version of the Scheme->C system. These patches add support for the Sun4/Sparcstation (SPARC), the Sun3 (SUN3), the Apollo DNx500 (APOLLO) and DN1000 (PRISM) series, the 386 (running ISC Unix ?), the NeXT, and the Sony News. Most of this is not new work, I simply integrated all the patches that were posted for the 28sep90 version and the 23feb90 version. I have verified this patch on the following machine/OS combinations: Sun4 - SunOS 4.1.1 Sun4 - SunOS 4.0.3 Sun3 - SunOS 4.1.1 Apollo DN3500 - Domain/OS SR10.2 (cc 6.7, I think) DEC DS/5000-200 - ULTRIX V4.1 DEC cVAX-GPX (most like a vax3500) - ULTRIX V4.0 How to use it. ============== This patch was generated against a fresh, unmodified version of the 01nov91 release of Scheme->C. I suggest you start with the original tar file and untar it. 1. cd into the top directory of the distribution. You should see something like this from ls -F: CHANGES README cdecl/ gnuemacs/ scrt/ test/ MIPS VAX doc/ makefile scsc/ xlib/ 2. Run the patch file through the patch program, like this ("this" assumes the patch file lives in the directory that is one level up from the top of the distribution): patch -p -b ".MCC" <../MCC01-01nov91.patches When patch is done, check to be sure there were no rejections. This can be done with the following command: find . -name '*.rej' -print If there were rejections, find out why and correct them. If it was due to a problem in the patch, please let me know. (I tried the patch on the above machines and it works for me :-) 3. Edit the top level makefile-tail (./makefile-tail) to fix up the definition of SRCDIR at a minimum. You may also want to change the various *DIR, *BIN, and *LIB macros that are appropriate for your environment. 4. Run a "make for" command, where ARCH is one of APOLLO, I386, ISC386IX, MIPS, NeXT, PRISM, SPARC, SUN3, TITAN, or VAX. This will create the $(CPUDIR) directory, if it does not exist. It will then create a tree of symbolic links to all the necessary files in the distribution. [ If you can accept the values for CPUDIR that already exist in the makefile, you can just say "make for SRCDIR=$PWD" where $PWD has a valid pathname to the currect directory] 5. cd into $(SRCDIR) which you set in #3 above. 6. Do a "make port" 7. Verify the build as in step #4 in the README file. I also suggest running more tests. This can be done like this: 4 >cd test 5 >../scrt/sci Scheme->C -- 01nov91jfb+MCC01 ... > (load "test.sc") MODULE form ignored (DEFINE-EXTERNAL TEST-ERRORS TESTCHK) TEST LOAD-TESTS "test.sc" > (load-tests) . lots of messages . > (test) ***** Begin Scheme->C Tests ***** . . ***** End Scheme->C Tests 0 Errors ***** #F > ^D 6 >make test 7 >./test 8 >cd .. You can also test the compiler by doing a "make test" in the test directory and then executing the "./test" program. It should produce the same results as the "(test)" above. 8. Because these patches modify some of the Scheme (.sc) files in the original distribution, the corresponding .c files need to be recompiled/rebuilt. This can be done with the command "make all". 9. Re-verify the system as in #7 above. More comments ============= Like I said, most of this work is not original. I simply took all the patches produced for the 28sep90 version and made them work. This involved fixing rejections, adding some new parts to the changes and removing some changes because the bug/problem they addressed was already fixed in the 01nov91 version. Here is a list of the authors of the original patches: SPARC - rec@arris.com (Roger Critchlow) I386 - rec@arris.com (Roger Critchlow) SUN3 - Mikael Pettersson APOLLO - Ray Lischner {uunet,decwrl}!mntgfx!lisch or lisch@mentor.com PRISM - Ray Lischner {uunet,decwrl}!mntgfx!lisch or lisch@mentor.com Sony News 3200 - Christian Queinnec queinnec@poly.polytechnique.fr NeXT - I don't have the name of the orignal author/porter of Scheme->C for the NeXT system. I must have lost the original posting to comp.lang.scheme. :-( However, David Broman (davbro@poincare.geom.umn.edu) and Scott S. Bertilson (scott@poincare.geom.umn.edu) tested my integration of the NeXT patches for the 28sep90 version. I am not able to verify the I386, PRISM, NeXT, nor the Sony version of the system. I don't have access to those kinds of machines. The I386 patches seemed to mix conditionals between the 386 and SysV. It would be nice if someone with a 386 and SysV could figure out what things are SysV requirements. There are more SysV problems, though. You should look at the README that originally came with Critchlow's SPARC-I386 patches. I have not tried to integrate the AMIGA port that Mike Meyer (mwm@wse.dec.com) provided for the 28sep90+MCC version of Scheme->C. Mostly it is because I forgot about that work. :-( The APOLLO and PRSIM machines don't usually have an assembler. Ray Lischner provided the assembler source and an assembled .o file. I have provided the uuencoded .o file. You could put the following section into the APOLLO makefile header to convert the uuencoded file into the .o file: apollo.o: apollo.o.uu uudecode apollo.o.uu There may be problems with the assembler, even if you have it. The assembler we have here at MCC will not take the muls.l or the mulu.l instructions. Conclusion ========== I hope you find these changes useful. If you have any problems please let me know. I appreciate any comments that you might have, good or bad. You can reach me via eckelkamp@mcc.com or uunet!cs.utexas.edu!milano!cadillac!davide. ____________________________________________________________________________ David Eckelkamp Microelectronics and Computer Technology Corp. (MCC) eckelkamp@mcc.com 3500 W. Balcones Center Dr. (512) 343-0978 Austin,TX 78759 *** /dev/null Thu Oct 31 13:45:26 1991 --- APOLLO Wed Oct 23 16:32:49 1991 *************** *** 0 **** --- 1,43 ---- + # + # This is the header file for constructing make files for Apollo 3000 + # series processors (DN3000, DN3500, DN4000, DN4500). + # + + .SUFFIXES: + .SUFFIXES: .o .c .sc .s .asm .bin + + # Processor name: + + cpu = APOLLO + + # Default flags to use when invoking the C compiler. + + OPT = -O + CFLAGS = $(OPT) -A cpu,3000 -A sys,bsd4.3 + CC = cc + CLIBS = -lm + + # Assembly language object files. + + Aruntime = apollo.o + + # The assembler does not normally come with Domain/OS. If you don't have the + # assembler, then you can just use the apollo.o file that is supplied. + #ASM = /usr/apollo/bin/asm + #AFLAGS = -nl -dba + + apollo.o : apollo.o.uu + uudecode C system for multiple processor types. # ! SRCDIR = /wrl/Gen/src/schemetoc MIPSDIR = /wrl/pmax/src/schemetoc MIPSBIN = /wrl/pmax/bin --- 2,9 ---- # This file is used to make the Scheme->C system for multiple processor types. # ! #SRCDIR = /usrwrl/Gen/src/schemetoc ! SRCDIR = $${PWD:=`pwd`} MIPSDIR = /wrl/pmax/src/schemetoc MIPSBIN = /wrl/pmax/bin *************** *** 16,31 **** VAXBIN = /wrl/vax/bin VAXLIB = /wrl/vax/lib # Architecture specific directories and links to the source files are # constructed by the following commands which follow: forCPU: -mkdir ${CPUDIR} cp ${CPU} ${CPUDIR} echo "BINDIR = ${BINDIR}" > ${CPUDIR}/makefile echo "LIBDIR = ${LIBDIR}" >> ${CPUDIR}/makefile ! cat makefile >> ${CPUDIR}/makefile @-echo @-echo '***** /doc *****' -mkdir ${CPUDIR}/doc --- 17,63 ---- VAXBIN = /wrl/vax/bin VAXLIB = /wrl/vax/lib + APOLLODIR = $(SRCDIR)/apollo + APOLLOBIN = $(SRCDIR)/bin.apollo + APOLLOLIB = $(SRCDIR)/lib.apollo + + PRISMDIR = $(SRCDIR)/prism + PRISMBIN = $(SRCDIR)/bin.prism + PRISMLIB = $(SRCDIR)/lib.prism + + SPARCDIR = ${SRCDIR}/sparc + SPARCBIN = ${SRCDIR}/bin.sparc + SPARCLIB = ${SRCDIR}/lib.sparc + + SUN3DIR = ${SRCDIR}/sun3 + SUN3BIN = ${SRCDIR}/bin.sun3 + SUN3LIB = ${SRCDIR}/lib.sun3 + + I386DIR = ${SRCDIR}/i386 + I386BIN = ${SRCDIR}/bin.i386 + I386LIB = ${SRCDIR}/lib.i386 + + NeXTDIR = ${SRCDIR}/next + NeXTBIN = /usr/local/bin + NeXTLIB = /usr/local/lib + + # This is a list of the machines/architectures that are currently supported. + # These are also the names of the necessary makefile fragements. + MACHINES = APOLLO I386 ISC386IX MIPS NeXT PRISM SPARC SUN3 TITAN VAX # Architecture specific directories and links to the source files are # constructed by the following commands which follow: + no-target: + @echo 'Use "make for", where is one of:' + @echo ' $(MACHINES)' + forCPU: -mkdir ${CPUDIR} cp ${CPU} ${CPUDIR} echo "BINDIR = ${BINDIR}" > ${CPUDIR}/makefile echo "LIBDIR = ${LIBDIR}" >> ${CPUDIR}/makefile ! cat makefile-tail >> ${CPUDIR}/makefile @-echo @-echo '***** /doc *****' -mkdir ${CPUDIR}/doc *************** *** 63,157 **** cat test/makefile-tail >> ${CPUDIR}/test/makefile -cd ${CPUDIR}/test; make srclinks forMIPS: ! make "CPU = MIPS" "CPUDIR = ${MIPSDIR}" \ "BINDIR = ${MIPSBIN}" "LIBDIR = ${MIPSLIB}" forCPU forTITAN: ! make "CPU = TITAN" "CPUDIR = ${TITANDIR}" \ "BINDIR = ${TITANBIN}" "LIBDIR = ${TITANLIB}" forCPU forVAX: ! make "CPU = VAX" "CPUDIR = ${VAXDIR}" \ "BINDIR = ${VAXBIN}" "LIBDIR = ${VAXLIB}" forCPU # The Scheme->C system is initially compiled from the C sources by the # following: port: ! cd scrt; make port ! cd scsc; make port # A "private" working copy of the current compiler, libary, and interpreter # is installed in a directory by the following command: install-private: ! cd scrt; make "destdir = ${destdir}" install-private ! cd scsc; make "destdir = ${destdir}" install-private # Clean out working files. clean: rm -f *.BAK *.CKP SC-TO-C* ! cd doc; make clean ! cd scrt; make clean ! cd scsc; make clean ! cd test; make clean # Clean up C source files generated from Scheme source. clean-sc-to-c: ! cd scrt; make clean-sc-to-c ! cd scsc; make clean-sc-to-c ! cd test; make clean-sc-to-c # Delete programs and libraries. noprogs: ! cd scrt; make noprogs ! cd scsc; make noprogs ! cd test; make noprogs # All binaries and documentation files are installed by the following command # for access by all users. install: ! cd doc; make "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install ! cd scrt; make "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install ! cd scsc; make "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install # All files which must be constructed are made by the following command: all: ! cd scrt; make all ! cd scsc; make all # Distribute "source" files required to make the Scheme->C system. srcdist: ! rdist -c MIPS README TITAN VAX makefile ${destdir} ! cd doc; make "destdir = ${destdir}/doc" srcdist ! -cd scbenchmark; make "destdir = ${destdir}/scbenchmark" srcdist ! cd scrt; make "destdir = ${destdir}/scrt" srcdist ! cd scsc; make "destdir = ${destdir}/scsc" srcdist ! -cd test; make "destdir = ${destdir}/test" srcdist ! -cd tools; make "destdir = ${destdir}/tools" srcdist # Distribute "binary" files so that they may be installed on some other # system. bindist: ! rdist -c MIPS README TITAN VAX makefile ${destdir} ! cd doc; make "destdir = ${destdir}/doc" bindist ! cd scrt; make "destdir = ${destdir}/scrt" bindist ! cd scsc; make "destdir = ${destdir}/scsc" bindist # Write the tar tape for distribution. ! TARFILES = CHANGES MIPS README VAX makefile \ ! doc/[a-z]*.mss doc/[a-z]*.psf doc/[a-z]*.l doc/makefile \ gnuemacs/README gnuemacs/[a-z]* \ scrt/[a-z]*.sc scrt/[a-z]*.[chs] scrt/makefile-tail \ scsc/[a-z]*.sc scsc/[a-z]*.c scsc/[a-z]*.sch scsc/makefile-tail \ test/[a-z]*.sc test/test54c.c test/makefile-tail \ cdecl/README cdecl/[a-z]* \ --- 95,260 ---- cat test/makefile-tail >> ${CPUDIR}/test/makefile -cd ${CPUDIR}/test; make srclinks + # Architecture specific makefiles are constructed by the + # following commands. + + inplaceCPU: + test -f makefile-tail || cp makefile makefile-tail + echo "BINDIR = ${BINDIR}" > makefile + echo "LIBDIR = ${LIBDIR}" >> makefile + cat makefile-tail >> makefile + test -f doc/makefile-tail || cp doc/makefile doc/makefile-tail + echo "SRCDIR = ${SRCDIR}/doc" > doc/makefile + cat doc/makefile-tail >> doc/makefile + cat ${CPU} > scrt/makefile + echo "SRCDIR = ${SRCDIR}/scrt" >> scrt/makefile + echo "CPUDIR = ${CPUDIR}/scrt" >> scrt/makefile + echo "BINDIR = ${BINDIR}" >> scrt/makefile + echo "LIBDIR = ${LIBDIR}" >> scrt/makefile + cat scrt/makefile-tail >> scrt/makefile + cat ${CPU} > scsc/makefile + echo "SRCDIR = ${SRCDIR}/scsc" >> scsc/makefile + echo "CPUDIR = ${CPUDIR}/scsc" >> scsc/makefile + echo "BINDIR = ${BINDIR}" >> scsc/makefile + echo "LIBDIR = ${LIBDIR}" >> scsc/makefile + cat scsc/makefile-tail >> scsc/makefile + cat ${CPU} > test/makefile + echo "SRCDIR = ${SRCDIR}/test" >> test/makefile + echo "CPUDIR = ${CPUDIR}/test" >> test/makefile + echo "BINDIR = ${BINDIR}" >> test/makefile + echo "LIBDIR = ${LIBDIR}" >> test/makefile + cat test/makefile-tail >> test/makefile + forMIPS: ! $(MAKE) "CPU = MIPS" "CPUDIR = ${MIPSDIR}" "SRCDIR = ${SRCDIR}" \ "BINDIR = ${MIPSBIN}" "LIBDIR = ${MIPSLIB}" forCPU forTITAN: ! $(MAKE) "CPU = TITAN" "CPUDIR = ${TITANDIR}" "SRCDIR = ${SRCDIR}" \ "BINDIR = ${TITANBIN}" "LIBDIR = ${TITANLIB}" forCPU forVAX: ! $(MAKE) "CPU = VAX" "CPUDIR = ${VAXDIR}" "SRCDIR = ${SRCDIR}" \ "BINDIR = ${VAXBIN}" "LIBDIR = ${VAXLIB}" forCPU + forAPOLLO: + $(MAKE) "CPU = APOLLO" "CPUDIR = ${APOLLODIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${APOLLOBIN}" "LIBDIR = ${APOLLOLIB}" forCPU + + forPRISM: + $(MAKE) "CPU = PRISM" "CPUDIR = ${PRISMDIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${PRISMBIN}" "LIBDIR = ${PRISMLIB}" forCPU + + forSPARC: + $(MAKE) "CPU = SPARC" "CPUDIR = ${SPARCDIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${SPARCBIN}" "LIBDIR = ${SPARCLIB}" forCPU + + + forSUN3: + $(MAKE) "CPU = SUN3" "CPUDIR = ${SUN3DIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR=${SUN3BIN}" "LIBDIR=${SUN3LIB}" forCPU + + forI386: + $(MAKE) "CPU = I386" "CPUDIR = ${I386DIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${I386BIN}" "LIBDIR = ${I386LIB}" forCPU + + forNeXT forNEXT: + $(MAKE) "CPU = NeXT" "CPUDIR = ${NeXTDIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${NeXTBIN}" "LIBDIR = ${NeXTLIB}" forCPU + + forI386-inplace: + $(MAKE) "CPU = I386" "CPUDIR = /usr/local/src/24mar90" \ + "SRCDIR = /usr/local/src/24mar90" \ + "BINDIR = /usr/local/bin" "LIBDIR = /usr/local/lib" inplaceCPU + + forISC386IX-inplace: + $(MAKE) "CPU = ISC386IX" "CPUDIR = /home/28sep90" \ + "SRCDIR = /home/28sep90" \ + "BINDIR = /usr/local/bin" "LIBDIR = /usr/local/lib" inplaceCPU + + forSPARC-inplace: + $(MAKE) "CPU = SPARC" "CPUDIR = ${SRCDIR}" \ + "SRCDIR = ${SRCDIR}" \ + "BINDIR = /usr/local/bin" "LIBDIR = /usr/local/lib" inplaceCPU + # The Scheme->C system is initially compiled from the C sources by the # following: port: ! cd scrt; $(MAKE) port ! cd scsc; $(MAKE) port # A "private" working copy of the current compiler, libary, and interpreter # is installed in a directory by the following command: install-private: ! cd scrt; $(MAKE) "destdir = ${destdir}" install-private ! cd scsc; $(MAKE) "destdir = ${destdir}" install-private # Clean out working files. clean: rm -f *.BAK *.CKP SC-TO-C* ! cd doc; $(MAKE) clean ! cd scrt; $(MAKE) clean ! cd scsc; $(MAKE) clean ! cd test; $(MAKE) clean # Clean up C source files generated from Scheme source. clean-sc-to-c: ! cd scrt; $(MAKE) clean-sc-to-c ! cd scsc; $(MAKE) clean-sc-to-c ! cd test; $(MAKE) clean-sc-to-c # Delete programs and libraries. noprogs: ! cd scrt; $(MAKE) noprogs ! cd scsc; $(MAKE) noprogs ! cd test; $(MAKE) noprogs # All binaries and documentation files are installed by the following command # for access by all users. install: ! cd doc; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install ! cd scrt; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install ! cd scsc; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install # All files which must be constructed are made by the following command: all: ! cd scrt; $(MAKE) all ! cd scsc; $(MAKE) all # Distribute "source" files required to make the Scheme->C system. srcdist: ! rdist -c $(MACHINES) README makefile makefile-tail ${destdir} ! cd doc; $(MAKE) "destdir = ${destdir}/doc" srcdist ! -cd scbenchmark; $(MAKE) "destdir = ${destdir}/scbenchmark" srcdist ! cd scrt; $(MAKE) "destdir = ${destdir}/scrt" srcdist ! cd scsc; $(MAKE) "destdir = ${destdir}/scsc" srcdist ! -cd test; $(MAKE) "destdir = ${destdir}/test" srcdist ! -cd tools; $(MAKE) "destdir = ${destdir}/tools" srcdist # Distribute "binary" files so that they may be installed on some other # system. bindist: ! rdist -c $(MACHINES) README makefile makefile-tail ${destdir} ! cd doc; $(MAKE) "destdir = ${destdir}/doc" bindist ! cd scrt; $(MAKE) "destdir = ${destdir}/scrt" bindist ! cd scsc; $(MAKE) "destdir = ${destdir}/scsc" bindist # Write the tar tape for distribution. ! TARFILES = CHANGES README $(MACHINES) makefile makefile-tail \ ! doc/[a-z]*.mss doc/[a-z]*.psf doc/[a-z]*.l doc/makefile doc/makefile-tail \ gnuemacs/README gnuemacs/[a-z]* \ scrt/[a-z]*.sc scrt/[a-z]*.[chs] scrt/makefile-tail \ + scrt/[a-z]*.asm scrt/*.uu \ scsc/[a-z]*.sc scsc/[a-z]*.c scsc/[a-z]*.sch scsc/makefile-tail \ test/[a-z]*.sc test/test54c.c test/makefile-tail \ cdecl/README cdecl/[a-z]* \ *** /dev/null Thu Oct 31 13:45:35 1991 --- makefile-tail Thu Oct 24 17:18:01 1991 *************** *** 0 **** --- 1,276 ---- + # + # This file is used to make the Scheme->C system for multiple processor types. + # + + #SRCDIR = /usrwrl/Gen/src/schemetoc + SRCDIR = $${PWD:=`pwd`} + + MIPSDIR = /wrl/pmax/src/schemetoc + MIPSBIN = /wrl/pmax/bin + MIPSLIB = /wrl/pmax/lib + + TITANDIR = /wrl/titan/src/schemetoc + TITANBIN = /wrl/titan/bin + TITANLIB = /wrl/titan/lib + + VAXDIR = /wrl/vax/src/schemetoc + VAXBIN = /wrl/vax/bin + VAXLIB = /wrl/vax/lib + + APOLLODIR = $(SRCDIR)/apollo + APOLLOBIN = $(SRCDIR)/bin.apollo + APOLLOLIB = $(SRCDIR)/lib.apollo + + PRISMDIR = $(SRCDIR)/prism + PRISMBIN = $(SRCDIR)/bin.prism + PRISMLIB = $(SRCDIR)/lib.prism + + SPARCDIR = ${SRCDIR}/sparc + SPARCBIN = ${SRCDIR}/bin.sparc + SPARCLIB = ${SRCDIR}/lib.sparc + + SUN3DIR = ${SRCDIR}/sun3 + SUN3BIN = ${SRCDIR}/bin.sun3 + SUN3LIB = ${SRCDIR}/lib.sun3 + + I386DIR = ${SRCDIR}/i386 + I386BIN = ${SRCDIR}/bin.i386 + I386LIB = ${SRCDIR}/lib.i386 + + NeXTDIR = ${SRCDIR}/next + NeXTBIN = /usr/local/bin + NeXTLIB = /usr/local/lib + + # This is a list of the machines/architectures that are currently supported. + # These are also the names of the necessary makefile fragements. + MACHINES = APOLLO I386 ISC386IX MIPS NeXT PRISM SPARC SUN3 TITAN VAX + + # Architecture specific directories and links to the source files are + # constructed by the following commands which follow: + + no-target: + @echo 'Use "make for", where is one of:' + @echo ' $(MACHINES)' + + forCPU: + -mkdir ${CPUDIR} + cp ${CPU} ${CPUDIR} + echo "BINDIR = ${BINDIR}" > ${CPUDIR}/makefile + echo "LIBDIR = ${LIBDIR}" >> ${CPUDIR}/makefile + cat makefile-tail >> ${CPUDIR}/makefile + @-echo + @-echo '***** /doc *****' + -mkdir ${CPUDIR}/doc + echo "SRCDIR = ${SRCDIR}/doc" > ${CPUDIR}/doc/makefile + cat doc/makefile >> ${CPUDIR}/doc/makefile + -cd ${CPUDIR}/doc; make srclinks + @-echo + @-echo '***** /scrt *****' + -mkdir ${CPUDIR}/scrt + cat ${CPU} > ${CPUDIR}/scrt/makefile + echo "SRCDIR = ${SRCDIR}/scrt" >> ${CPUDIR}/scrt/makefile + echo "CPUDIR = ${CPUDIR}/scrt" >> ${CPUDIR}/scrt/makefile + echo "BINDIR = ${BINDIR}" >> ${CPUDIR}/scrt/makefile + echo "LIBDIR = ${LIBDIR}" >> ${CPUDIR}/scrt/makefile + cat scrt/makefile-tail >> ${CPUDIR}/scrt/makefile + -cd ${CPUDIR}/scrt; make srclinks + @-echo + @-echo '***** /scsc *****' + -mkdir ${CPUDIR}/scsc + cat ${CPU} > ${CPUDIR}/scsc/makefile + echo "SRCDIR = ${SRCDIR}/scsc" >> ${CPUDIR}/scsc/makefile + echo "CPUDIR = ${CPUDIR}/scsc" >> ${CPUDIR}/scsc/makefile + echo "BINDIR = ${BINDIR}" >> ${CPUDIR}/scsc/makefile + echo "LIBDIR = ${LIBDIR}" >> ${CPUDIR}/scsc/makefile + cat scsc/makefile-tail >> ${CPUDIR}/scsc/makefile + -cd ${CPUDIR}/scsc; make srclinks + @-echo + @-echo '***** /test *****' + -mkdir ${CPUDIR}/test + cat ${CPU} > ${CPUDIR}/test/makefile + echo "SRCDIR = ${SRCDIR}/test" >> ${CPUDIR}/test/makefile + echo "CPUDIR = ${CPUDIR}/test" >> ${CPUDIR}/test/makefile + echo "BINDIR = ${BINDIR}" >> ${CPUDIR}/test/makefile + echo "LIBDIR = ${LIBDIR}" >> ${CPUDIR}/test/makefile + cat test/makefile-tail >> ${CPUDIR}/test/makefile + -cd ${CPUDIR}/test; make srclinks + + # Architecture specific makefiles are constructed by the + # following commands. + + inplaceCPU: + test -f makefile-tail || cp makefile makefile-tail + echo "BINDIR = ${BINDIR}" > makefile + echo "LIBDIR = ${LIBDIR}" >> makefile + cat makefile-tail >> makefile + test -f doc/makefile-tail || cp doc/makefile doc/makefile-tail + echo "SRCDIR = ${SRCDIR}/doc" > doc/makefile + cat doc/makefile-tail >> doc/makefile + cat ${CPU} > scrt/makefile + echo "SRCDIR = ${SRCDIR}/scrt" >> scrt/makefile + echo "CPUDIR = ${CPUDIR}/scrt" >> scrt/makefile + echo "BINDIR = ${BINDIR}" >> scrt/makefile + echo "LIBDIR = ${LIBDIR}" >> scrt/makefile + cat scrt/makefile-tail >> scrt/makefile + cat ${CPU} > scsc/makefile + echo "SRCDIR = ${SRCDIR}/scsc" >> scsc/makefile + echo "CPUDIR = ${CPUDIR}/scsc" >> scsc/makefile + echo "BINDIR = ${BINDIR}" >> scsc/makefile + echo "LIBDIR = ${LIBDIR}" >> scsc/makefile + cat scsc/makefile-tail >> scsc/makefile + cat ${CPU} > test/makefile + echo "SRCDIR = ${SRCDIR}/test" >> test/makefile + echo "CPUDIR = ${CPUDIR}/test" >> test/makefile + echo "BINDIR = ${BINDIR}" >> test/makefile + echo "LIBDIR = ${LIBDIR}" >> test/makefile + cat test/makefile-tail >> test/makefile + + forMIPS: + $(MAKE) "CPU = MIPS" "CPUDIR = ${MIPSDIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${MIPSBIN}" "LIBDIR = ${MIPSLIB}" forCPU + + forTITAN: + $(MAKE) "CPU = TITAN" "CPUDIR = ${TITANDIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${TITANBIN}" "LIBDIR = ${TITANLIB}" forCPU + + forVAX: + $(MAKE) "CPU = VAX" "CPUDIR = ${VAXDIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${VAXBIN}" "LIBDIR = ${VAXLIB}" forCPU + + forAPOLLO: + $(MAKE) "CPU = APOLLO" "CPUDIR = ${APOLLODIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${APOLLOBIN}" "LIBDIR = ${APOLLOLIB}" forCPU + + forPRISM: + $(MAKE) "CPU = PRISM" "CPUDIR = ${PRISMDIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${PRISMBIN}" "LIBDIR = ${PRISMLIB}" forCPU + + forSPARC: + $(MAKE) "CPU = SPARC" "CPUDIR = ${SPARCDIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${SPARCBIN}" "LIBDIR = ${SPARCLIB}" forCPU + + + forSUN3: + $(MAKE) "CPU = SUN3" "CPUDIR = ${SUN3DIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR=${SUN3BIN}" "LIBDIR=${SUN3LIB}" forCPU + + forI386: + $(MAKE) "CPU = I386" "CPUDIR = ${I386DIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${I386BIN}" "LIBDIR = ${I386LIB}" forCPU + + forNeXT forNEXT: + $(MAKE) "CPU = NeXT" "CPUDIR = ${NeXTDIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${NeXTBIN}" "LIBDIR = ${NeXTLIB}" forCPU + + forI386-inplace: + $(MAKE) "CPU = I386" "CPUDIR = /usr/local/src/24mar90" \ + "SRCDIR = /usr/local/src/24mar90" \ + "BINDIR = /usr/local/bin" "LIBDIR = /usr/local/lib" inplaceCPU + + forISC386IX-inplace: + $(MAKE) "CPU = ISC386IX" "CPUDIR = /home/28sep90" \ + "SRCDIR = /home/28sep90" \ + "BINDIR = /usr/local/bin" "LIBDIR = /usr/local/lib" inplaceCPU + + forSPARC-inplace: + $(MAKE) "CPU = SPARC" "CPUDIR = ${SRCDIR}" \ + "SRCDIR = ${SRCDIR}" \ + "BINDIR = /usr/local/bin" "LIBDIR = /usr/local/lib" inplaceCPU + + # The Scheme->C system is initially compiled from the C sources by the + # following: + + port: + cd scrt; $(MAKE) port + cd scsc; $(MAKE) port + + # A "private" working copy of the current compiler, libary, and interpreter + # is installed in a directory by the following command: + + install-private: + cd scrt; $(MAKE) "destdir = ${destdir}" install-private + cd scsc; $(MAKE) "destdir = ${destdir}" install-private + + # Clean out working files. + + clean: + rm -f *.BAK *.CKP SC-TO-C* + cd doc; $(MAKE) clean + cd scrt; $(MAKE) clean + cd scsc; $(MAKE) clean + cd test; $(MAKE) clean + + # Clean up C source files generated from Scheme source. + + clean-sc-to-c: + cd scrt; $(MAKE) clean-sc-to-c + cd scsc; $(MAKE) clean-sc-to-c + cd test; $(MAKE) clean-sc-to-c + + # Delete programs and libraries. + + noprogs: + cd scrt; $(MAKE) noprogs + cd scsc; $(MAKE) noprogs + cd test; $(MAKE) noprogs + + # All binaries and documentation files are installed by the following command + # for access by all users. + + install: + cd doc; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install + cd scrt; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install + cd scsc; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install + + # All files which must be constructed are made by the following command: + + all: + cd scrt; $(MAKE) all + cd scsc; $(MAKE) all + + # Distribute "source" files required to make the Scheme->C system. + + srcdist: + rdist -c $(MACHINES) README makefile makefile-tail ${destdir} + cd doc; $(MAKE) "destdir = ${destdir}/doc" srcdist + -cd scbenchmark; $(MAKE) "destdir = ${destdir}/scbenchmark" srcdist + cd scrt; $(MAKE) "destdir = ${destdir}/scrt" srcdist + cd scsc; $(MAKE) "destdir = ${destdir}/scsc" srcdist + -cd test; $(MAKE) "destdir = ${destdir}/test" srcdist + -cd tools; $(MAKE) "destdir = ${destdir}/tools" srcdist + + # Distribute "binary" files so that they may be installed on some other + # system. + + bindist: + rdist -c $(MACHINES) README makefile makefile-tail ${destdir} + cd doc; $(MAKE) "destdir = ${destdir}/doc" bindist + cd scrt; $(MAKE) "destdir = ${destdir}/scrt" bindist + cd scsc; $(MAKE) "destdir = ${destdir}/scsc" bindist + + # Write the tar tape for distribution. + + TARFILES = CHANGES README $(MACHINES) makefile makefile-tail \ + doc/[a-z]*.mss doc/[a-z]*.psf doc/[a-z]*.l doc/makefile doc/makefile-tail \ + gnuemacs/README gnuemacs/[a-z]* \ + scrt/[a-z]*.sc scrt/[a-z]*.[chs] scrt/makefile-tail \ + scrt/[a-z]*.asm scrt/*.uu \ + scsc/[a-z]*.sc scsc/[a-z]*.c scsc/[a-z]*.sch scsc/makefile-tail \ + test/[a-z]*.sc test/test54c.c test/makefile-tail \ + cdecl/README cdecl/[a-z]* \ + xlib/README xlib/[X-z]* + + TARFLAGS = -cl + + tartape: + tar ${TARFLAGS} ${TARFILES} + + tarlog: + tar tvf ${TARTAPE} > ${TARLOG} + + tarZ: + make "TARFLAGS=-clf tartape-${DATE}" tartape + make "TARTAPE=tartape-${DATE}" "TARLOG=tartapelog-${DATE}" tarlog + cp tartape-${DATE} tt-${DATE} + compress tt-${DATE} + *** /dev/null Thu Oct 31 13:45:52 1991 --- doc/makefile-tail Wed Oct 23 16:32:59 1991 *************** *** 0 **** --- 1,38 ---- + # + # Makefile for distributing the Scheme->C documentation. + # + + port: + + clean: + rm -f *.BAK *.CKP *.o core + + clean-sc-to-c: + rm -f *.c + + noprogs: + + install: + -install -c scc.l ${DESTROOT}/usr/local/man/man1/scc.1 + -install -c sci.l ${DESTROOT}/usr/local/man/man1/sci.1 + -mkdir ${DESTROOT}/usr/doc/local/schemetoc + -install -c intro.psf ${DESTROOT}/usr/doc/local/schemetoc/intro.psf + -install -c index.psf ${DESTROOT}/usr/doc/local/schemetoc/index.psf + + srcdist: + rdist -c README makefile-tail index.psf index.mss intro.psf intro.mss \ + scc.l sci.l ${destdir} + + bindist: + rdist -c README makefile-tail makefile index.psf intro.psf \ + scc.l sci.l ${destdir} + + srclinks: + ln -s ${SRCDIR}/index.psf index.psf + ln -s ${SRCDIR}/index.mss index.mss + ln -s ${SRCDIR}/intro.psf intro.psf + ln -s ${SRCDIR}/intro.mss intro.mss + ln -s ${SRCDIR}/scc.l scc.l + ln -s ${SRCDIR}/sci.l sci.l + + all: *** 1.1 1991/10/23 18:48:13 --- gnuemacs/README 1991/10/23 21:30:32 *************** *** 1 **** --- 1,49 ---- Gnu emacs lisp code use with the Scheme to C compiler. + + ---- NOTES from David Eckelkamp @ MCC.com ---------------- + + This directory contains 2 versions of an inferior Scheme mode for GNU + emacs. The files s2c-gnuemacs.* are the ones that came with Scheme->C + originally. The rest of the files are the latest version of the CMU + developed "General command interpreter in a window stuff", namely + comint.el and cmu*.el. The s2c-gnuemacs.el appears to have been + derived from an earlier version of comint.el and cmuscheme.el. + + You can use either of these packages to provide a better way to + interact with the Scheme->C interpreter. Some of the questions and + answers in the s2c-gnuemacs.README file relevant to cmulisp, also. + However, the installation instructions are not exactly the same. Look + at the top of cmuscheme.el for complete details on cmuscheme mode. I + have included at the bottom of this file some parts of my scheme-mode + hacks. They all work well with Scheme->C. + + I have included the file comint-fix.DE in this directory. It is a + patch of stuff from Leonard N. Zubkoff and his apollo port of GNU + Emacs. It provides what I consider to be better support for filename + completion in the comint derived modes. After you apply the patch and + recompile comint.el heres what you should see. As soon as you hit the + filename completion key a buffer will pop up on the screen if there is + not a unique completion. Then you just type more characters until the + filename is complete. After you hit return to send the command line + to the shell, the termporary buffer of completions is removed and the + screen returned to its previous state. + + ---- some usefull scheme hacks for GNU Emacs ---------------- + + (setq scheme-mode-hook + '((lambda () + (autoload 'run-scheme "cmuscheme" "Run an inferior Scheme" t) + ))) + + (autoload 'run-scheme "cmuscheme" "Run an inferior Scheme" t) + + ;;; Fix up the auto-mode-alist to recognize various scheme file extensions + (setq auto-mode-alist + (append + (list + (cons "\\.scm$" 'scheme-mode) + (cons "\\.sc$" 'scheme-mode) + (cons "\\.sch$" 'scheme-mode) + ) + auto-mode-alist)) + *** /dev/null Thu Oct 31 13:46:05 1991 --- gnuemacs/cmugdb.el Wed Oct 23 16:33:00 1991 *************** *** 0 **** --- 1,401 ---- + ;; Run gdb under Emacs + ;; Author: W. Schelter, University of Texas + ;; wfs@rascal.ics.utexas.edu + ;; Rewritten by rms. + + ;; Some ideas are due to Masanobu. + + ;; Modified to use comint by Dale Worley (drw@math.mit.edu). + + ;; This file is part of GNU Emacs. + ;; Copyright (C) 1988 Free Software Foundation, Inc. + + ;; GNU Emacs is distributed in the hope that it will be useful, but + ;; WITHOUT ANY WARRANTY. No author or distributor accepts responsibility + ;; to anyone for the consequences of using it or for whether it serves + ;; any particular purpose or works at all, unless he says so in writing. + ;; Refer to the GNU Emacs General Public License for full details. + + ;; Everyone is granted permission to copy, modify and redistribute GNU + ;; Emacs, but only under the conditions described in the GNU Emacs + ;; General Public License. A copy of this license is supposed to have + ;; been given to you along with GNU Emacs so you can know your rights and + ;; responsibilities. It should be in a file named COPYING. Among other + ;; things, the copyright notice and this notice must be preserved on all + ;; copies. + + ;; Description of GDB interface: + + ;; A facility is provided for the simultaneous display of the source code + ;; in one window, while using gdb to step through a function in the + ;; other. A small arrow in the source window, indicates the current + ;; line. + + ;; Starting up: + + ;; In order to use this facility, invoke the command GDB to obtain a + ;; shell window with the appropriate command bindings. You will be asked + ;; for the name of a file to run. Gdb will be invoked on this file, in a + ;; window named *gdb-foo* if the file is foo. + + ;; M-s steps by one line, and redisplays the source file and line. + + ;; You may easily create additional commands and bindings to interact + ;; with the display. For example to put the gdb command next on \M-n + ;; (def-gdb next "\M-n") + + ;; This causes the emacs command gdb-next to be defined, and runs + ;; gdb-display-frame after the command. + + ;; gdb-display-frame is the basic display function. It tries to display + ;; in the other window, the file and line corresponding to the current + ;; position in the gdb window. For example after a gdb-step, it would + ;; display the line corresponding to the position for the last step. Or + ;; if you have done a backtrace in the gdb buffer, and move the cursor + ;; into one of the frames, it would display the position corresponding to + ;; that frame. + + ;; gdb-display-frame is invoked automatically when a filename-and-line-number + ;; appears in the output. + + + (require 'cmushell) ; cmushell requires comint, so we don't + ; have to specify it ourselves + + (defvar gdb-prompt-pattern "^(.*gdb[+]?) *" + "A regexp to recognize the prompt for gdb or gdb+.") + + (defvar gdb-mode-map nil + "Keymap for gdb-mode.") + + (if gdb-mode-map + nil + (setq gdb-mode-map (copy-keymap cmushell-mode-map)) + (define-key gdb-mode-map "\C-l" 'gdb-refresh)) + + (define-key ctl-x-map " " 'gdb-break) + (define-key ctl-x-map "&" 'send-gdb-command) + + ;;Of course you may use `def-gdb' with any other gdb command, including + ;;user defined ones. + + (defmacro def-gdb (name key &optional doc) + (let* ((fun (intern (format "gdb-%s" name))) + (cstr (list 'if '(not (= 1 arg)) + (list 'format "%s %s" name 'arg) + name))) + (list 'progn + (list 'defun fun '(arg) + (or doc "") + '(interactive "p") + (list 'gdb-call cstr)) + (list 'define-key 'gdb-mode-map key (list 'quote fun))))) + + (def-gdb "step" "\M-s" "Step one source line with display") + (def-gdb "stepi" "\M-i" "Step one instruction with display") + (def-gdb "next" "\M-n" "Step one source line (skip functions)") + (def-gdb "cont" "\M-c" "Continue with display") + + (def-gdb "finish" "\C-c\C-f" "Finish executing current function") + (def-gdb "up" "\M-u" "Go up N stack frames (numeric arg) with display") + (def-gdb "down" "\M-d" "Go down N stack frames (numeric arg) with display") + + (defun gdb-mode () + "Major mode for interacting with an inferior Gdb process. + The following commands are available: + + \\{gdb-mode-map} + + \\[gdb-display-frame] displays in the other window + the last line referred to in the gdb buffer. + + \\[gdb-step],\\[gdb-next], and \\[gdb-nexti] in the gdb window, + call gdb to step,next or nexti and then update the other window + with the current file and position. + + If you are in a source file, you may select a point to break + at, by doing \\[gdb-break]. + + Commands: + Many commands are inherited from shell mode. + Additionally we have: + + \\[gdb-display-frame] display frames file in other window + \\[gdb-step] advance one line in program + \\[gdb-next] advance one line in program (skip over calls). + \\[send-gdb-command] used for special printing of an arg at the current point. + C-x SPACE sets break point at current line." + (interactive) + (kill-all-local-variables) + (comint-mode) + (setq comint-prompt-regexp "^(gdb) ") + (setq major-mode 'gdb-mode) + (setq mode-name "Inferior Gdb") + (setq mode-line-process '(": %s")) + (use-local-map gdb-mode-map) + (make-local-variable 'last-input-start) + (setq last-input-start (make-marker)) + (make-local-variable 'last-input-end) + (setq last-input-end (make-marker)) + (make-local-variable 'gdb-last-frame) + (setq gdb-last-frame nil) + (make-local-variable 'gdb-last-frame-displayed-p) + (setq gdb-last-frame-displayed-p t) + (make-local-variable 'gdb-delete-prompt-marker) + (setq gdb-delete-prompt-marker nil) + (make-local-variable 'gdb-filter-accumulator) + (setq gdb-filter-accumulator nil) + (make-local-variable 'shell-prompt-pattern) + (setq shell-prompt-pattern gdb-prompt-pattern) + (run-hooks 'cmushell-mode-hook 'gdb-mode-hook)) + + (defvar current-gdb-buffer nil) + + (defvar gdb-command-name "gdb" + "Pathname for executing gdb.") + + (defun gdb (path) + "Run gdb on program FILE in buffer *gdb-FILE*. + The directory containing FILE becomes the initial working directory + and source-file directory for GDB. If you wish to change this, use + the GDB commands `cd DIR' and `directory'." + (interactive "FRun gdb on file: ") + (setq path (expand-file-name path)) + (let ((file (file-name-nondirectory path))) + (switch-to-buffer (concat "*gdb-" file "*")) + (setq default-directory (file-name-directory path)) + (or (bolp) (newline)) + (insert "Current directory is " default-directory "\n") + (make-comint (concat "gdb-" file) gdb-command-name nil "-fullname" + "-cd" default-directory file) + (gdb-mode) + (set-process-filter (get-buffer-process (current-buffer)) 'gdb-filter) + (set-process-sentinel (get-buffer-process (current-buffer)) 'gdb-sentinel) + (gdb-set-buffer))) + + (defun gdb-set-buffer () + (cond ((eq major-mode 'gdb-mode) + (setq current-gdb-buffer (current-buffer))))) + + ;; This function is responsible for inserting output from GDB + ;; into the buffer. + ;; Aside from inserting the text, it notices and deletes + ;; each filename-and-line-number; + ;; that GDB prints to identify the selected frame. + ;; It records the filename and line number, and maybe displays that file. + (defun gdb-filter (proc string) + (let ((inhibit-quit t)) + (if gdb-filter-accumulator + (gdb-filter-accumulate-marker proc + (concat gdb-filter-accumulator string)) + (gdb-filter-scan-input proc string)))) + + (defun gdb-filter-accumulate-marker (proc string) + (setq gdb-filter-accumulator nil) + (if (> (length string) 1) + (if (= (aref string 1) ?\032) + (let ((end (string-match "\n" string))) + (if end + (progn + (let* ((first-colon (string-match ":" string 2)) + (second-colon + (string-match ":" string (1+ first-colon)))) + (setq gdb-last-frame + (cons (substring string 2 first-colon) + (string-to-int + (substring string (1+ first-colon) + second-colon))))) + (setq gdb-last-frame-displayed-p nil) + (gdb-filter-scan-input proc + (substring string (1+ end)))) + (setq gdb-filter-accumulator string))) + (gdb-filter-insert proc "\032") + (gdb-filter-scan-input proc (substring string 1))) + (setq gdb-filter-accumulator string))) + + (defun gdb-filter-scan-input (proc string) + (if (equal string "") + (setq gdb-filter-accumulator nil) + (let ((start (string-match "\032" string))) + (if start + (progn (gdb-filter-insert proc (substring string 0 start)) + (gdb-filter-accumulate-marker proc + (substring string start))) + (gdb-filter-insert proc string))))) + + (defun gdb-filter-insert (proc string) + (let ((moving (= (point) (process-mark proc))) + (output-after-point (< (point) (process-mark proc))) + (old-buffer (current-buffer)) + start) + (set-buffer (process-buffer proc)) + (unwind-protect + (save-excursion + ;; Insert the text, moving the process-marker. + (goto-char (process-mark proc)) + (setq start (point)) + (insert string) + (set-marker (process-mark proc) (point)) + (gdb-maybe-delete-prompt) + ;; Check for a filename-and-line number. + (gdb-display-frame + ;; Don't display the specified file + ;; unless (1) point is at or after the position where output appears + ;; and (2) this buffer is on the screen. + (or output-after-point + (not (get-buffer-window (current-buffer)))) + ;; Display a file only when a new filename-and-line-number appears. + t)) + (set-buffer old-buffer)) + (if moving (goto-char (process-mark proc))))) + + (defun gdb-sentinel (proc msg) + (cond ((null (buffer-name (process-buffer proc))) + ;; buffer killed + ;; Stop displaying an arrow in a source file. + (setq overlay-arrow-position nil) + (set-process-buffer proc nil)) + ((memq (process-status proc) '(signal exit)) + ;; Stop displaying an arrow in a source file. + (setq overlay-arrow-position nil) + ;; Fix the mode line. + (setq mode-line-process + (concat ": " + (symbol-name (process-status proc)))) + (let* ((obuf (current-buffer))) + ;; save-excursion isn't the right thing if + ;; process-buffer is current-buffer + (unwind-protect + (progn + ;; Write something in *compilation* and hack its mode line, + (set-buffer (process-buffer proc)) + ;; Force mode line redisplay soon + (set-buffer-modified-p (buffer-modified-p)) + (if (eobp) + (insert ?\n mode-name " " msg) + (save-excursion + (goto-char (point-max)) + (insert ?\n mode-name " " msg))) + ;; If buffer and mode line will show that the process + ;; is dead, we can delete it now. Otherwise it + ;; will stay around until M-x list-processes. + (delete-process proc)) + ;; Restore old buffer, but don't restore old point + ;; if obuf is the gdb buffer. + (set-buffer obuf)))))) + + + (defun gdb-refresh () + "Fix up a possibly garbled display, and redraw the arrow." + (interactive) + (redraw-display) + (gdb-display-frame)) + + (defun gdb-display-frame (&optional nodisplay noauto) + "Find, obey and delete the last filename-and-line marker from GDB. + The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n. + Obeying it means displaying in another window the specified file and line." + (interactive) + (gdb-set-buffer) + (and gdb-last-frame (not nodisplay) + (or (not gdb-last-frame-displayed-p) (not noauto)) + (progn (gdb-display-line (car gdb-last-frame) (cdr gdb-last-frame)) + (setq gdb-last-frame-displayed-p t)))) + + ;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen + ;; and that its line LINE is visible. + ;; Put the overlay-arrow on the line LINE in that buffer. + + (defun gdb-display-line (true-file line) + (let* ((buffer (find-file-noselect true-file)) + (window (display-buffer buffer t)) + (pos)) + (save-excursion + (set-buffer buffer) + (save-restriction + (widen) + (goto-line line) + (setq pos (point)) + (setq overlay-arrow-string "=>") + (or overlay-arrow-position + (setq overlay-arrow-position (make-marker))) + (set-marker overlay-arrow-position (point) (current-buffer))) + (cond ((or (< pos (point-min)) (> pos (point-max))) + (widen) + (goto-char pos)))) + (set-window-point window overlay-arrow-position))) + + (defun gdb-call (command) + "Invoke gdb COMMAND displaying source in other window." + (interactive) + (goto-char (point-max)) + (setq gdb-delete-prompt-marker (point-marker)) + (gdb-set-buffer) + (send-string (get-buffer-process current-gdb-buffer) + (concat command "\n"))) + + (defun gdb-maybe-delete-prompt () + (if (and gdb-delete-prompt-marker + (> (point-max) (marker-position gdb-delete-prompt-marker))) + (let (start) + (goto-char gdb-delete-prompt-marker) + (setq start (point)) + (beginning-of-line) + (delete-region (point) start) + (setq gdb-delete-prompt-marker nil)))) + + (defun gdb-break () + "Set GDB breakpoint at this source line." + (interactive) + (let ((file-name (file-name-nondirectory buffer-file-name)) + (line (save-restriction + (widen) + (1+ (count-lines 1 (point)))))) + (send-string (get-buffer-process current-gdb-buffer) + (concat "break " file-name ":" line "\n")))) + + (defun gdb-read-address() + "Return a string containing the core-address found in the buffer at point." + (save-excursion + (let ((pt (dot)) found begin) + (setq found (if (search-backward "0x" (- pt 7) t)(dot))) + (cond (found (forward-char 2)(setq result + (buffer-substring found + (progn (re-search-forward "[^0-9a-f]") + (forward-char -1) + (dot))))) + (t (setq begin (progn (re-search-backward "[^0-9]") (forward-char 1) + (dot))) + (forward-char 1) + (re-search-forward "[^0-9]") + (forward-char -1) + (buffer-substring begin (dot))))))) + + + (defvar gdb-commands nil + "List of strings or functions used by send-gdb-command. + It is for customization by you.") + + (defun send-gdb-command (arg) + + "This command reads the number where the cursor is positioned. It + then inserts this ADDR at the end of the gdb buffer. A numeric arg + selects the ARG'th member COMMAND of the list gdb-print-command. If + COMMAND is a string, (format COMMAND ADDR) is inserted, otherwise + (funcall COMMAND ADDR) is inserted. eg. \"p (rtx)%s->fld[0].rtint\" + is a possible string to be a member of gdb-commands. " + + + (interactive "P") + (let (comm addr) + (if arg (setq comm (nth arg gdb-commands))) + (setq addr (gdb-read-address)) + (if (eq (current-buffer) current-gdb-buffer) + (set-mark (point))) + (cond (comm + (setq comm + (if (stringp comm) (format comm addr) (funcall comm addr)))) + (t (setq comm addr))) + (switch-to-buffer current-gdb-buffer) + (goto-char (dot-max)) + (insert-string comm))) *** /dev/null Thu Oct 31 13:46:06 1991 --- gnuemacs/cmulisp.el Wed Oct 23 16:33:01 1991 *************** *** 0 **** --- 1,595 ---- + ;;; -*-Emacs-Lisp-*- cmulisp.el + ;;; Copyright Olin Shivers (1988). + ;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright + ;;; notice appearing here to the effect that you may use this code any + ;;; way you like, as long as you don't charge money for it, remove this + ;;; notice, or hold me liable for its results. + + ;;; This replaces the standard inferior-lisp mode. + ;;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88 + ;;; Please send me bug reports, bug fixes, and extensions, so that I can + ;;; merge them into the master source. + ;;; + ;;; Change log at end of file. + + ;;; This file defines a a lisp-in-a-buffer package (cmulisp mode) built on top + ;;; of comint mode. Cmulisp mode is similar to, and intended to replace, its + ;;; counterpart in the standard gnu emacs release. This replacements is more + ;;; featureful, robust, and uniform than the released 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 cmulisp 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 cmulisp (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? + + (require 'comint) + (provide 'cmulisp) + + ;; YOUR .EMACS FILE + ;;============================================================================= + ;; Some suggestions for your .emacs file. + ;; + ;; ; If cmulisp lives in some non-standard directory, you must tell emacs + ;; ; where to get it. This may or may not be necessary. + ;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path)) + ;; + ;; ; Autoload cmulisp from file cmulisp.el + ;; (autoload 'cmulisp "cmulisp" + ;; "Run an inferior Lisp process." + ;; t) + ;; + ;; ; Define C-c C-t to run my favorite command in cmulisp mode: + ;; (setq cmulisp-load-hook + ;; '((lambda () + ;; (define-key cmulisp-mode-map "\C-c\C-t" 'favorite-cmd)))) + + + ;;; Brief Command Documentation: + ;;;============================================================================ + ;;; Comint Mode Commands: (common to cmulisp and all comint-derived modes) + ;;; + ;;; m-p comint-previous-input Cycle backwards in input history + ;;; m-n comint-next-input Cycle forwards + ;;; c-c r comint-previous-input-matching Search backwards in input history + ;;; return comint-send-input + ;;; c-a comint-bol Beginning of line; skip prompt. + ;;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff. + ;;; c-c c-u comint-kill-input ^u + ;;; c-c c-w backward-kill-word ^w + ;;; c-c c-c comint-interrupt-subjob ^c + ;;; c-c c-z comint-stop-subjob ^z + ;;; c-c c-\ comint-quit-subjob ^\ + ;;; c-c c-o comint-kill-output Delete last batch of process output + ;;; c-c c-r comint-show-output Show last batch of process output + ;;; send-invisible Read line w/o echo & send to proc + ;;; comint-continue-subjob Useful if you accidentally suspend + ;;; top-level job. + ;;; comint-mode-hook is the comint mode hook. + + ;;; CMU Lisp Mode Commands: + ;;; c-m-x lisp-send-defun This binding is a gnu convention. + ;;; c-c l lisp-load-file Prompt for file name; tell Lisp to load it. + ;;; c-c k lisp-compile-file Prompt for file name; tell Lisp to kompile it. + ;;; Filename completion is available, of course. + ;;; + ;;; Additionally, these commands are added to the key bindings of Lisp mode: + ;;; c-m-x lisp-eval-defun This binding is a gnu convention. + ;;; c-c e lisp-eval-defun Send the current defun to Lisp process. + ;;; c-x c-e lisp-eval-last-sexp Send the previous sexp to Lisp process. + ;;; c-c c-e lisp-eval-defun-and-go After sending the defun, switch-to-lisp. + ;;; c-c r lisp-eval-region Send the current region to Lisp process. + ;;; c-c c-r lisp-eval-region-and-go After sending the region, switch-to-lisp. + ;;; c-c c lisp-compile-defun Compile the current defun in Lisp process. + ;;; c-c c-c lisp-compile-defun-and-go After compiling defun, switch-to-lisp. + ;;; c-c z switch-to-lisp Switch to the Lisp process buffer. + ;;; c-c l lisp-load-file (See above. In a Lisp file buffer, default + ;;; c-c k lisp-compile-file is to load/compile the current file.) + ;;; c-c c-d lisp-describe-sym Query Lisp for a symbol's description. + ;;; c-c a lisp-show-arglist Query Lisp for function's arglist. + ;;; c-c f lisp-show-function-documentation Query Lisp for a function's doc. + ;;; c-c v lisp-show-variable-documentation Query Lisp for a variable's doc. + + ;;; cmulisp Fires up the Lisp process. + ;;; lisp-compile-region Compile all forms in the current region. + ;;; lisp-compile-region-and-go After compiling region, switch-to-lisp. + ;;; + ;;; CMU Lisp Mode Variables: + ;;; cmulisp-filter-regexp Match this => don't get saved on input hist + ;;; inferior-lisp-program Name of Lisp program run-lisp executes + ;;; inferior-lisp-load-command Customises lisp-load-file + ;;; cmulisp-mode-hook + ;;; inferior-lisp-prompt Initialises comint-prompt-regexp. + ;;; Backwards compatibility. + ;;; lisp-source-modes Anything loaded into a buffer that's in + ;;; one of these modes is considered Lisp + ;;; source by lisp-load/compile-file. + + ;;; Read the rest of this file for more information. + + (defvar cmulisp-filter-regexp "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'" + "*What not to save on inferior Lisp's input history + Input matching this regexp is not saved on the input history in cmulisp + mode. Default is whitespace followed by 0 or 1 single-letter :keyword + (as in :a, :c, etc.)") + + (defvar cmulisp-mode-map nil) + (cond ((not cmulisp-mode-map) + (setq cmulisp-mode-map + (full-copy-sparse-keymap comint-mode-map)) + (lisp-mode-commands cmulisp-mode-map) + (define-key cmulisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) + (define-key cmulisp-mode-map "\C-cl" 'lisp-load-file) + (define-key cmulisp-mode-map "\C-ck" 'lisp-compile-file) + (define-key cmulisp-mode-map "\C-ca" 'lisp-show-arglist) + (define-key cmulisp-mode-map "\C-c\C-d" 'lisp-describe-sym) + (define-key cmulisp-mode-map "\C-cf" 'lisp-show-function-documentation) + (define-key cmulisp-mode-map "\C-cv" 'lisp-show-variable-documentation))) + + ;;; These commands augment Lisp mode, so you can process Lisp code in + ;;; the source files. + (define-key lisp-mode-map "\M-\C-x" 'lisp-eval-defun) ; Gnu convention + (define-key lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) ; Gnu convention + (define-key lisp-mode-map "\C-ce" 'lisp-eval-defun) + (define-key lisp-mode-map "\C-c\C-e" 'lisp-eval-defun-and-go) + (define-key lisp-mode-map "\C-cr" 'lisp-eval-region) + (define-key lisp-mode-map "\C-c\C-r" 'lisp-eval-region-and-go) + (define-key lisp-mode-map "\C-cc" 'lisp-compile-defun) + (define-key lisp-mode-map "\C-c\C-c" 'lisp-compile-defun-and-go) + (define-key lisp-mode-map "\C-cz" 'switch-to-lisp) + (define-key lisp-mode-map "\C-cl" 'lisp-load-file) + (define-key lisp-mode-map "\C-ck" 'lisp-compile-file) ; "kompile" file + (define-key lisp-mode-map "\C-ca" 'lisp-show-arglist) + (define-key lisp-mode-map "\C-c\C-d" 'lisp-describe-sym) + (define-key lisp-mode-map "\C-cf" 'lisp-show-function-documentation) + (define-key lisp-mode-map "\C-cv" 'lisp-show-variable-documentation) + + + (defvar inferior-lisp-program "lisp" + "*Program name for invoking an inferior Lisp with `cmulisp'.") + + (defvar inferior-lisp-load-command "(load \"%s\")\n" + "*Format-string for building a Lisp expression to load a file. + This format string should use %s to substitute a file name + and should result in a Lisp expression that will command the inferior Lisp + to load that file. The default works acceptably on most Lisps. + The string \"(progn (load \\\"%s\\\" :verbose nil :print t) (values))\\\n\" + produces cosmetically superior output for this application, + but it works only in Common Lisp.") + + (defvar inferior-lisp-prompt "^[^> ]*>+:? *" + "Regexp to recognise prompts in the inferior Lisp. + Defaults to \"^[^> ]*>+:? *\", which works pretty good for Lucid, kcl, + and franz. This variable is used to initialise comint-prompt-regexp in the + cmulisp buffer. + + More precise choices: + Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\" + franz: \"^\\(->\\|<[0-9]*>:\\) *\" + kcl: \"^>+ *\" + + This is a fine thing to set in your .emacs file.") + + (defvar cmulisp-mode-hook '() + "*Hook for customising cmulisp mode") + + (defun cmulisp-mode () + "Major mode for interacting with an inferior Lisp process. + Runs a Lisp interpreter as a subprocess of Emacs, with Lisp I/O through an + Emacs buffer. Variable inferior-lisp-program controls which Lisp interpreter + is run. Variables inferior-lisp-prompt, cmulisp-filter-regexp and + inferior-lisp-load-command can customize this mode for different Lisp + interpreters. + + For information on running multiple processes in multiple buffers, see + documentation for variable cmulisp-buffer. + + \\{cmulisp-mode-map} + + Customisation: Entry to this mode runs the hooks on comint-mode-hook and + cmulisp-mode-hook (in that order). + + You can send text to the inferior Lisp process from other buffers containing + Lisp source. + switch-to-lisp switches the current buffer to the Lisp process buffer. + lisp-eval-defun sends the current defun to the Lisp process. + lisp-compile-defun compiles the current defun. + lisp-eval-region sends the current region to the Lisp process. + lisp-compile-region compiles the current region. + + lisp-eval-defun-and-go, lisp-compile-defun-and-go, + lisp-eval-region-and-go, and lisp-compile-region-and-go + switch to the Lisp process buffer after sending their 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 Lisp; 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-lisp-prompt) + (setq major-mode 'cmulisp-mode) + (setq mode-name "CMU Lisp") + (setq mode-line-process '(": %s")) + (if (string-match "^18.4" emacs-version) ; hack. + (lisp-mode-variables) ; This is right for 18.49 + (lisp-mode-variables t)) ; This is right for 18.50 + (use-local-map cmulisp-mode-map) ;c-c k for "kompile" file + (setq comint-get-old-input (function lisp-get-old-input)) + (setq comint-input-filter (function lisp-input-filter)) + (setq comint-input-sentinel 'ignore) + (run-hooks 'cmulisp-mode-hook)) + + (defun lisp-get-old-input () + "Snarf the sexp ending at point" + (save-excursion + (let ((end (point))) + (backward-sexp) + (buffer-substring (point) end)))) + + (defun lisp-input-filter (str) + "Don't save anything matching cmulisp-filter-regexp" + (not (string-match cmulisp-filter-regexp str))) + + (defun cmulisp () + "Run an inferior Lisp process, input and output via buffer *cmulisp*. + If there is a process already running in *cmulisp*, just switch to that buffer. + Takes the program name from the variable inferior-lisp-program. + \(Type \\[describe-mode] in the process buffer for a list of commands.)" + (interactive) + (cond ((not (comint-check-proc "*cmulisp*")) + (set-buffer (make-comint "cmulisp" inferior-lisp-program)) + (cmulisp-mode))) + (setq cmulisp-buffer "*cmulisp*") + (switch-to-buffer "*cmulisp*")) + + (defun lisp-eval-region (start end) + "Send the current region to the inferior Lisp process." + (interactive "r") + (comint-send-region (cmulisp-proc) start end) + (comint-send-string (cmulisp-proc) "\n")) + + (defun lisp-eval-defun () + "Send the current defun to the inferior Lisp process." + (interactive) + (save-excursion + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (lisp-eval-region (point) end)))) + + (defun lisp-eval-last-sexp () + "Send the previous sexp to the inferior Lisp process." + (interactive) + (lisp-eval-region (save-excursion (backward-sexp) (point)) (point))) + + ;;; CommonLisp COMPILE sux. + (defun lisp-compile-region (start end) + "Compile the current region in the inferior Lisp process." + (interactive "r") + (comint-send-string (cmulisp-proc) + (format "(funcall (compile nil `(lambda () (progn 'compile %s))))\n" + (buffer-substring start end)))) + + (defun lisp-compile-defun () + "Compile the current defun in the inferior Lisp process." + (interactive) + (save-excursion + (end-of-defun) + (let ((e (point))) + (beginning-of-defun) + (lisp-compile-region (point) e)))) + + (defun switch-to-lisp (eob-p) + "Switch to the inferior Lisp process buffer. + With argument, positions cursor at end of buffer." + (interactive "P") + (if (get-buffer cmulisp-buffer) + (pop-to-buffer cmulisp-buffer) + (error "No current process buffer. See variable cmulisp-buffer.")) + (cond (eob-p + (push-mark) + (goto-char (point-max))))) + + (defun lisp-eval-region-and-go (start end) + "Send the current region to the inferior Lisp, + and switch to the process buffer." + (interactive "r") + (lisp-eval-region start end) + (switch-to-lisp t)) + + (defun lisp-eval-defun-and-go () + "Send the current defun to the inferior Lisp, + and switch to the process buffer." + (interactive) + (lisp-eval-defun) + (switch-to-lisp t)) + + (defun lisp-compile-region-and-go (start end) + "Compile the current region in the inferior Lisp, + and switch to the process buffer." + (interactive "r") + (lisp-compile-region start end) + (switch-to-lisp t)) + + (defun lisp-compile-defun-and-go () + "Compile the current defun in the inferior Lisp, + and switch to the process buffer." + (interactive) + (lisp-compile-defun) + (switch-to-lisp t)) + + ;;; A version of the form in H. Shevis' soar-mode.el package. Less robust. + ;(defun lisp-compile-sexp (start end) + ; "Compile the s-expression bounded by START and END in the inferior lisp. + ;If the sexp isn't a DEFUN form, it is evaluated instead." + ; (cond ((looking-at "(defun\\s +") + ; (goto-char (match-end 0)) + ; (let ((name-start (point))) + ; (forward-sexp 1) + ; (process-send-string "cmulisp" (format "(compile '%s #'(lambda " + ; (buffer-substring name-start + ; (point))))) + ; (let ((body-start (point))) + ; (goto-char start) (forward-sexp 1) ; Can't use end-of-defun. + ; (process-send-region "cmulisp" (buffer-substring body-start (point)))) + ; (process-send-string "cmulisp" ")\n")) + ; (t (lisp-eval-region start end))))) + ; + ;(defun lisp-compile-region (start end) + ; "Each s-expression in the current region is compiled (if a DEFUN) + ;or evaluated (if not) in the inferior lisp." + ; (interactive "r") + ; (save-excursion + ; (goto-char start) (end-of-defun) (beginning-of-defun) ; error check + ; (if (< (point) start) (error "region begins in middle of defun")) + ; (goto-char start) + ; (let ((s start)) + ; (end-of-defun) + ; (while (<= (point) end) ; Zip through + ; (lisp-compile-sexp s (point)) ; compiling up defun-sized chunks. + ; (setq s (point)) + ; (end-of-defun)) + ; (if (< s end) (lisp-compile-sexp s end))))) + ;;; + ;;; End of HS-style code + + + (defvar lisp-prev-l/c-dir/file nil + "Saves the (directory . file) pair used in the last lisp-load-file or + lisp-compile-file command. Used for determining the default in the + next one.") + + (defvar lisp-source-modes '(lisp-mode) + "*Used to determine if a buffer contains Lisp source code. + If it's loaded into a buffer that is in one of these major modes, it's + considered a Lisp source file by lisp-load-file and lisp-compile-file. + Used by these commands to determine defaults.") + + (defun lisp-load-file (file-name) + "Load a Lisp file into the inferior Lisp process." + (interactive (comint-get-source "Load Lisp file: " lisp-prev-l/c-dir/file + lisp-source-modes nil)) ; NIL because LOAD + ; doesn't need an exact name + (comint-check-source file-name) ; Check to see if buffer needs saved. + (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) + (file-name-nondirectory file-name))) + (comint-send-string (cmulisp-proc) + (format inferior-lisp-load-command file-name)) + (switch-to-lisp t)) + + + (defun lisp-compile-file (file-name) + "Compile a Lisp file in the inferior Lisp process." + (interactive (comint-get-source "Compile Lisp file: " lisp-prev-l/c-dir/file + lisp-source-modes nil)) ; NIL = don't need + ; suffix .lisp + (comint-check-source file-name) ; Check to see if buffer needs saved. + (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) + (file-name-nondirectory file-name))) + (comint-send-string (cmulisp-proc) (concat "(compile-file \"" + file-name + "\"\)\n")) + (switch-to-lisp t)) + + + + ;;; Documentation functions: function doc, var doc, arglist, and + ;;; describe symbol. + ;;; =========================================================================== + + ;;; Command strings + ;;; =============== + + (defvar lisp-function-doc-command + "(let ((fn '%s)) + (format t \"Documentation for ~a:~&~a\" + fn (documentation fn 'function)) + (values))\n" + "Command to query inferior Lisp for a function's documentation.") + + (defvar lisp-var-doc-command + "(let ((v '%s)) + (format t \"Documentation for ~a:~&~a\" + v (documentation v 'variable)) + (values))\n" + "Command to query inferior Lisp for a variable's documentation.") + + (defvar lisp-arglist-command + "(let ((fn '%s)) + (format t \"Arglist for ~a: ~a\" fn (arglist fn)) + (values))\n" + "Command to query inferior Lisp for a function's arglist.") + + (defvar lisp-describe-sym-command + "(describe '%s)\n" + "Command to query inferior Lisp for a variable's documentation.") + + + ;;; Ancillary functions + ;;; =================== + + ;;; Reads a string from the user. + (defun lisp-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 lisp-fn-called-at-pt () + "Returns the name of the function called in the current call. + 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 (read (current-buffer)))) + (and (symbolp obj) obj)))) + (error nil))) + + + ;;; Adapted from variable-at-point in help.el. + (defun lisp-var-at-pt () + (condition-case () + (save-excursion + (forward-sexp -1) + (skip-chars-forward "'") + (let ((obj (read (current-buffer)))) + (and (symbolp obj) obj))) + (error nil))) + + + ;;; Documentation functions: fn and var doc, arglist, and symbol describe. + ;;; ====================================================================== + + (defun lisp-show-function-documentation (fn) + "Send a command to the inferior Lisp to give documentation for function FN. + See variable lisp-function-doc-command." + (interactive (lisp-symprompt "Function doc" (lisp-fn-called-at-pt))) + (comint-proc-query (cmulisp-proc) (format lisp-function-doc-command fn))) + + (defun lisp-show-variable-documentation (var) + "Send a command to the inferior Lisp to give documentation for function FN. + See variable lisp-var-doc-command." + (interactive (lisp-symprompt "Variable doc" (lisp-var-at-pt))) + (comint-proc-query (cmulisp-proc) (format lisp-var-doc-command var))) + + (defun lisp-show-arglist (fn) + "Sends an query to the inferior Lisp for the arglist for function FN. + See variable lisp-arglist-command." + (interactive (lisp-symprompt "Arglist" (lisp-fn-called-at-pt))) + (comint-proc-query (cmulisp-proc) (format lisp-arglist-command fn))) + + (defun lisp-describe-sym (sym) + "Send a command to the inferior Lisp to describe symbol SYM. + See variable lisp-describe-sym-command." + (interactive (lisp-symprompt "Describe" (lisp-var-at-pt))) + (comint-proc-query (cmulisp-proc) (format lisp-describe-sym-command sym))) + + + (defvar cmulisp-buffer nil "*The current cmulisp process buffer. + + MULTIPLE PROCESS SUPPORT + =========================================================================== + Cmulisp.el supports, in a fairly simple fashion, running multiple Lisp + processes. To run multiple Lisp processes, you start the first up with + \\[cmulisp]. It will be in a buffer named *cmulisp*. Rename this buffer + with \\[rename-buffer]. You may now start up a new process with another + \\[cmulisp]. It will be in a new buffer, named *cmulisp*. You can + switch between the different process buffers with \\[switch-to-buffer]. + + Commands that send text from source buffers to Lisp processes -- + like lisp-eval-defun or lisp-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 cmulisp-buffer. Suppose you + have three inferior lisps running: + Buffer Process + foo cmulisp + bar cmulisp<2> + *cmulisp* cmulisp<3> + If you do a \\[lisp-eval-defun-and-go] command on some Lisp source code, + what process do you send it to? + + - If you're in a process buffer (foo, bar, or *cmulisp*), + 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 cmulisp-buffer. + This process selection is performed by function cmulisp-proc. + + Whenever \\[cmulisp] fires up a new process, it resets cmulisp-buffer + to be the new process's buffer. If you only run one process, this will + do the right thing. If you run multiple processes, you can change + cmulisp-buffer to another process buffer with \\[set-variable]. + + More sophisticated approaches are, of course, possible. If you find youself + needing to switch back and forth between multiple processes frequently, + you may wish to consider ilisp.el, a larger, more sophisticated package + for running inferior Lisp processes. The approach taken here is for a + minimal, simple implementation. Feel free to extend it.") + + (defun cmulisp-proc () + "Returns the current cmulisp process. See variable cmulisp-buffer." + (let ((proc (get-buffer-process (if (eq major-mode 'inferior-lisp-mode) + (current-buffer) + cmulisp-buffer)))) + (or proc + (error "No current process. See variable cmulisp-buffer")))) + + + ;;; Do the user's customisation... + ;;;=============================== + (defvar cmulisp-load-hook nil + "This hook is run when cmulisp is loaded in. + This is a good place to put keybindings.") + + (run-hooks 'cmulisp-load-hook) + + ;;; CHANGE LOG + ;;; =========================================================================== + ;;; 5/24/90 Olin + ;;; - Split cmulisp and cmushell modes into separate files. + ;;; Not only is this a good idea, it's apparently the way it'll be rel 19. + ;;; - Upgraded process sends to use comint-send-string instead of + ;;; process-send-string. + ;;; - Explicit references to process "cmulisp" have been replaced with + ;;; (cmulisp-proc). This allows better handling of multiple process bufs. + ;;; - Added process query and var/function/symbol documentation + ;;; commands. Based on code written by Douglas Roberts. + ;;; - Added lisp-eval-last-sexp, bound to C-x C-e. *** /dev/null Thu Oct 31 13:46:07 1991 --- gnuemacs/cmuscheme.el Wed Oct 23 16:33:03 1991 *************** *** 0 **** --- 1,428 ---- + ;;; cmuscheme.el -- Scheme process in a buffer. Adapted from tea.el. + ;;; Copyright Olin Shivers (1988) + ;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright + ;;; notice appearing here to the effect that you may use this code any + ;;; way you like, as long as you don't charge money for it, remove this + ;;; notice, or hold me liable for its results. + ;;; + ;;; This is a customisation of comint-mode (see comint.el) + ;;; + ;;; Written by Olin Shivers (olin.shivers@cs.cmu.edu). With bits and pieces + ;;; lifted from scheme.el, shell.el, clisp.el, newclisp.el, cobol.el, et al.. + ;;; 8/88 + ;;; + ;;; Please send me bug reports, bug fixes, and extensions, so that I can + ;;; merge them into the master source. + ;;; + ;;; The changelog is at the end of this file. + ;;; + ;;; NOTE: MIT Cscheme, when invoked with the -emacs flag, has a special user + ;;; interface that communicates process state back to the superior emacs by + ;;; outputting special control sequences. The gnumacs package, xscheme.el, has + ;;; lots and lots of special purpose code to read these control sequences, and + ;;; so is very tightly integrated with the cscheme process. The cscheme + ;;; interrupt handler and debugger read single character commands in cbreak + ;;; mode; when this happens, xscheme.el switches to special keymaps that bind + ;;; the single letter command keys to emacs functions that directly send the + ;;; character to the scheme process. Cmuscheme mode does *not* provide this + ;;; functionality. If you are a cscheme user, you may prefer to use the + ;;; xscheme.el/cscheme -emacs interaction. + ;;; + ;;; Here's a summary of the pros and cons, as I see them. + ;;; xscheme: Tightly integrated with inferior cscheme process! A few commands + ;;; not in cmuscheme. But. Integration is a bit of a hack. Input + ;;; history only keeps the immediately prior input. Bizarre + ;;; keybindings. + ;;; + ;;; cmuscheme: Not tightly integrated with inferior cscheme process. But. + ;;; Carefully integrated functionality with the entire suite of + ;;; comint-derived CMU process modes. Keybindings reminiscent of + ;;; Zwei and Hemlock. Good input history. A few commands not in + ;;; xscheme. + ;;; + ;;; It's a tradeoff. Pay your money; take your choice. If you use a Scheme + ;;; that isn't Cscheme, of course, there isn't a choice. Xscheme.el is *very* + ;;; Cscheme-specific; you must use cmuscheme.el. Interested parties are + ;;; invited to port xscheme functionality on top of comint mode... + + ;; YOUR .EMACS FILE + ;;============================================================================= + ;; Some suggestions for your .emacs file. + ;; + ;; ; If cmuscheme lives in some non-standard directory, you must tell emacs + ;; ; where to get it. This may or may not be necessary. + ;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path)) + ;; + ;; ; Autoload run-scheme from file cmuscheme.el + ;; (autoload 'run-scheme "cmuscheme" + ;; "Run an inferior Scheme process." + ;; t) + ;; + ;; ; Files ending in ".scm" are Scheme source, + ;; ; so put their buffers in scheme-mode. + ;; (setq auto-mode-alist + ;; (cons '("\\.scm$" . scheme-mode) + ;; auto-mode-alist)) + ;; + ;; ; Define C-c C-t to run my favorite command in inferior scheme mode: + ;; (setq cmuscheme-load-hook + ;; '((lambda () (define-key inferior-scheme-mode-map "\C-c\C-t" + ;; 'favorite-cmd)))) + ;;; + ;;; Unfortunately, scheme.el defines run-scheme to autoload from xscheme.el. + ;;; This will womp your declaration to autoload run-scheme from cmuscheme.el + ;;; if you haven't loaded cmuscheme in before scheme. Three fixes: + ;;; - Put the autoload on your scheme mode hook and in your .emacs toplevel: + ;;; (setq scheme-mode-hook + ;;; '((lambda () (autoload 'run-scheme "cmuscheme" + ;;; "Run an inferior Scheme" t)))) + ;;; (autoload 'run-scheme "cmuscheme" "Run an inferior Scheme" t) + ;;; Now when scheme.el autoloads, it will restore the run-scheme autoload. + ;;; - Load cmuscheme.el in your .emacs: (load-library 'cmuscheme) + ;;; - Change autoload declaration in scheme.el to point to cmuscheme.el: + ;;; (autoload 'run-scheme "cmuscheme" "Run an inferior Scheme" t) + ;;; *or* just delete the autoload declaration from scheme.el altogether, + ;;; which will allow the autoload in your .emacs to have its say. + + (provide 'cmuscheme) + (require 'scheme) + (require 'comint) + + ;;; INFERIOR SCHEME MODE STUFF + ;;;============================================================================ + + (defvar inferior-scheme-mode-hook nil + "*Hook for customising inferior-scheme mode.") + (defvar inferior-scheme-mode-map nil) + + (cond ((not inferior-scheme-mode-map) + (setq inferior-scheme-mode-map + (full-copy-sparse-keymap comint-mode-map)) + (define-key inferior-scheme-mode-map "\M-\C-x" ;gnu convention + 'scheme-send-definition) + (define-key inferior-scheme-mode-map "\C-x\C-e" 'scheme-send-last-sexp) + (define-key inferior-scheme-mode-map "\C-cl" 'scheme-load-file) + (define-key inferior-scheme-mode-map "\C-ck" 'scheme-compile-file) + (scheme-mode-commands inferior-scheme-mode-map))) + + ;; Install the process communication commands in the scheme-mode keymap. + (define-key scheme-mode-map "\M-\C-x" 'scheme-send-definition);gnu convention + (define-key scheme-mode-map "\C-x\C-e" 'scheme-send-last-sexp);gnu convention + (define-key scheme-mode-map "\C-ce" 'scheme-send-definition) + (define-key scheme-mode-map "\C-c\C-e" 'scheme-send-definition-and-go) + (define-key scheme-mode-map "\C-cr" 'scheme-send-region) + (define-key scheme-mode-map "\C-c\C-r" 'scheme-send-region-and-go) + (define-key scheme-mode-map "\C-cc" 'scheme-compile-definition) + (define-key scheme-mode-map "\C-c\C-c" 'scheme-compile-definition-and-go) + (define-key scheme-mode-map "\C-cz" 'switch-to-scheme) + (define-key scheme-mode-map "\C-cl" 'scheme-load-file) + (define-key scheme-mode-map "\C-ck" 'scheme-compile-file) ;k for "kompile" + + (defun inferior-scheme-mode () + "Major mode for interacting with an inferior Scheme process. + + The following commands are available: + \\{inferior-scheme-mode-map} + + A Scheme process can be fired up with M-x run-scheme. + + Customisation: Entry to this mode runs the hooks on comint-mode-hook and + inferior-scheme-mode-hook (in that order). + + You can send text to the inferior Scheme process from other buffers containing + Scheme source. + switch-to-scheme switches the current buffer to the Scheme process buffer. + scheme-send-definition sends the current definition to the Scheme process. + scheme-compile-definition compiles the current definition. + scheme-send-region sends the current region to the Scheme process. + scheme-compile-region compiles the current region. + + scheme-send-definition-and-go, scheme-compile-definition-and-go, + scheme-send-region-and-go, and scheme-compile-region-and-go + switch to the Scheme process buffer after sending their text. + For information on running multiple processes in multiple buffers, see + documentation for variable scheme-buffer. + + 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 Scheme; 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) + ;; Customise in inferior-scheme-mode-hook + (setq comint-prompt-regexp "^[^>]*>+ *") ; OK for cscheme, oaklisp, T,... + (scheme-mode-variables) + (setq major-mode 'inferior-scheme-mode) + (setq mode-name "Inferior Scheme") + (setq mode-line-process '(": %s")) + (use-local-map inferior-scheme-mode-map) + (setq comint-input-filter (function scheme-input-filter)) + (setq comint-input-sentinel (function ignore)) + (setq comint-get-old-input (function scheme-get-old-input)) + (run-hooks 'inferior-scheme-mode-hook)) + + (defun scheme-input-filter (str) + "Don't save anything matching inferior-scheme-filter-regexp" + (not (string-match inferior-scheme-filter-regexp str))) + + (defvar inferior-scheme-filter-regexp "\\`\\s *\\S ?\\S ?\\s *\\'" + "*Input matching this regexp are not saved on the history list. + Defaults to a regexp ignoring all inputs of 0, 1, or 2 letters.") + + (defun scheme-get-old-input () + "Snarf the sexp ending at point" + (save-excursion + (let ((end (point))) + (backward-sexp) + (buffer-substring (point) end)))) + + (defun scheme-args-to-list (string) + (let ((where (string-match "[ \t]" string))) + (cond ((null where) (list string)) + ((not (= where 0)) + (cons (substring string 0 where) + (scheme-args-to-list (substring string (+ 1 where) + (length string))))) + (t (let ((pos (string-match "[^ \t]" string))) + (if (null pos) + nil + (scheme-args-to-list (substring string pos + (length string))))))))) + + (defvar scheme-program-name "scheme" + "*Program invoked by the run-scheme command") + + ;;; Obsolete + (defun scheme (&rest foo) + "Use run-scheme" + (interactive) + (message "Use run-scheme") + (ding)) + + (defun run-scheme (cmd) + "Run an inferior Scheme process, input and output via buffer *scheme*. + If there is a process already running in *scheme*, just switch to that buffer. + With argument, allows you to edit the command line (default is value + of scheme-program-name). Runs the hooks from inferior-scheme-mode-hook + \(after the comint-mode-hook is run). + \(Type \\[describe-mode] in the process buffer for a list of commands.)" + + (interactive (list (if current-prefix-arg + (read-string "Run Scheme: " scheme-program-name) + scheme-program-name))) + (if (not (comint-check-proc "*scheme*")) + (let ((cmdlist (scheme-args-to-list cmd))) + (set-buffer (apply 'make-comint "scheme" (car cmdlist) + nil (cdr cmdlist))) + (inferior-scheme-mode))) + (setq scheme-buffer "*scheme*") + (switch-to-buffer "*scheme*")) + + + (defun scheme-send-region (start end) + "Send the current region to the inferior Scheme process." + (interactive "r") + (comint-send-region (scheme-proc) start end) + (comint-send-string (scheme-proc) "\n")) + + (defun scheme-send-definition () + "Send the current definition to the inferior Scheme process." + (interactive) + (save-excursion + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (scheme-send-region (point) end)))) + + (defun scheme-send-last-sexp () + "Send the previous sexp to the inferior Scheme process." + (interactive) + (scheme-send-region (save-excursion (backward-sexp) (point)) (point))) + + (defvar scheme-compile-exp-command "(compile '%s)" + "*Template for issuing commands to compile arbitrary Scheme expressions.") + + (defun scheme-compile-region (start end) + "Compile the current region in the inferior Scheme process + \(A BEGIN is wrapped around the region: (BEGIN ))" + (interactive "r") + (comint-send-string (scheme-proc) (format scheme-compile-exp-command + (format "(begin %s)" + (buffer-substring start end)))) + (comint-send-string (scheme-proc) "\n")) + + (defun scheme-compile-definition () + "Compile the current definition in the inferior Scheme process." + (interactive) + (save-excursion + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (scheme-compile-region (point) end)))) + + (defun switch-to-scheme (eob-p) + "Switch to the scheme process buffer. + With argument, positions cursor at end of buffer." + (interactive "P") + (if (get-buffer scheme-buffer) + (pop-to-buffer scheme-buffer) + (error "No current process buffer. See variable scheme-buffer.")) + (cond (eob-p + (push-mark) + (goto-char (point-max))))) + + (defun scheme-send-region-and-go (start end) + "Send the current region to the inferior Scheme process, + and switch to the process buffer." + (interactive "r") + (scheme-send-region start end) + (switch-to-scheme t)) + + (defun scheme-send-definition-and-go () + "Send the current definition to the inferior Scheme, + and switch to the process buffer." + (interactive) + (scheme-send-definition) + (switch-to-scheme t)) + + (defun scheme-compile-definition-and-go () + "Compile the current definition in the inferior Scheme, + and switch to the process buffer." + (interactive) + (scheme-compile-definition) + (switch-to-scheme t)) + + (defun scheme-compile-region-and-go (start end) + "Compile the current region in the inferior Scheme, + and switch to the process buffer." + (interactive "r") + (scheme-compile-region start end) + (switch-to-scheme t)) + + (defvar scheme-source-modes '(scheme-mode) + "*Used to determine if a buffer contains Scheme source code. + If it's loaded into a buffer that is in one of these major modes, it's + considered a scheme source file by scheme-load-file and scheme-compile-file. + Used by these commands to determine defaults.") + + (defvar scheme-prev-l/c-dir/file nil + "Caches the (directory . file) pair used in the last scheme-load-file or + scheme-compile-file command. Used for determining the default in the + next one.") + + (defun scheme-load-file (file-name) + "Load a Scheme file into the inferior Scheme process." + (interactive (comint-get-source "Load Scheme file: " scheme-prev-l/c-dir/file + scheme-source-modes t)) ; T because LOAD + ; needs an exact name + (comint-check-source file-name) ; Check to see if buffer needs saved. + (setq scheme-prev-l/c-dir/file (cons (file-name-directory file-name) + (file-name-nondirectory file-name))) + (comint-send-string (scheme-proc) (concat "(load \"" + file-name + "\"\)\n")) + (switch-to-scheme t)) + + (defun scheme-compile-file (file-name) + "Compile a Scheme file in the inferior Scheme process." + (interactive (comint-get-source "Compile Scheme file: " + scheme-prev-l/c-dir/file + scheme-source-modes + nil)) ; NIL because COMPILE doesn't + ; need an exact name. + (comint-check-source file-name) ; Check to see if buffer needs saved. + (setq scheme-prev-l/c-dir/file (cons (file-name-directory file-name) + (file-name-nondirectory file-name))) + (comint-send-string (scheme-proc) (concat "(compile-file \"" + file-name + "\"\)\n")) + (switch-to-scheme t)) + + + (defvar scheme-buffer nil "*The current scheme process buffer. + + MULTIPLE PROCESS SUPPORT + =========================================================================== + Cmuscheme.el supports, in a fairly simple fashion, running multiple Scheme + processes. To run multiple Scheme processes, you start the first up with + \\[run-scheme]. It will be in a buffer named *scheme*. Rename this buffer + with \\[rename-buffer]. You may now start up a new process with another + \\[run-scheme]. It will be in a new buffer, named *scheme*. You can + switch between the different process buffers with \\[switch-to-buffer]. + + Commands that send text from source buffers to Scheme processes -- + like scheme-send-definition or scheme-compile-region -- have to choose a + process to send to, when you have more than one Scheme process around. This + is determined by the global variable scheme-buffer. Suppose you + have three inferior Schemes running: + Buffer Process + foo scheme + bar scheme<2> + *scheme* scheme<3> + If you do a \\[scheme-send-definition-and-go] command on some Scheme source + code, what process do you send it to? + + - If you're in a process buffer (foo, bar, or *scheme*), + 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 scheme-buffer. + This process selection is performed by function scheme-proc. + + Whenever \\[run-scheme] fires up a new process, it resets scheme-buffer + to be the new process's buffer. If you only run one process, this will + do the right thing. If you run multiple processes, you can change + scheme-buffer to another process buffer with \\[set-variable]. + + More sophisticated approaches are, of course, possible. If you find youself + needing to switch back and forth between multiple processes frequently, + you may wish to consider ilisp.el, a larger, more sophisticated package + for running inferior Lisp and Scheme processes. The approach taken here is + for a minimal, simple implementation. Feel free to extend it.") + + (defun scheme-proc () + "Returns the current scheme process. See variable scheme-buffer." + (let ((proc (get-buffer-process (if (eq major-mode 'inferior-scheme-mode) + (current-buffer) + scheme-buffer)))) + (or proc + (error "No current process. See variable scheme-buffer")))) + + + ;;; Do the user's customisation... + + (defvar cmuscheme-load-hook nil + "This hook is run when cmuscheme is loaded in. + This is a good place to put keybindings.") + + (run-hooks 'cmuscheme-load-hook) + + + ;;; CHANGE LOG + ;;; =========================================================================== + ;;; 8/88 Olin + ;;; Created. + ;;; + ;;; 2/15/89 Olin + ;;; Removed -emacs flag from process invocation. It's only useful for + ;;; cscheme, and makes cscheme assume it's running under xscheme.el, + ;;; which messes things up royally. A bug. + ;;; + ;;; 5/22/90 Olin + ;;; - Upgraded to use comint-send-string and comint-send-region. + ;;; - run-scheme now offers to let you edit the command line if + ;;; you invoke it with a prefix-arg. M-x scheme is redundant, and + ;;; has been removed. + ;;; - Explicit references to process "scheme" have been replaced with + ;;; (scheme-proc). This allows better handling of multiple process bufs. + ;;; - Added scheme-send-last-sexp, bound to C-x C-e. A gnu convention. + ;;; - Have not added process query facility a la cmulisp.el's lisp-show-arglist + ;;; and friends, but interested hackers might find a useful application + ;;; of this facility. *** /dev/null Thu Oct 31 13:46:08 1991 --- gnuemacs/cmushell.el Wed Oct 23 16:33:04 1991 *************** *** 0 **** --- 1,587 ---- + ;;; -*-Emacs-Lisp-*- General command interpreter in a window stuff + ;;; Copyright Olin Shivers (1988). + ;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright + ;;; notice appearing here to the effect that you may use this code any + ;;; way you like, as long as you don't charge money for it, remove this + ;;; notice, or hold me liable for its results. + + ;;; The changelog is at the end of file. + + ;;; Please send me bug reports, bug fixes, and extensions, so that I can + ;;; merge them into the master source. + ;;; - Olin Shivers (shivers@cs.cmu.edu) + + ;;; This file defines a a shell-in-a-buffer package (cmushell mode) built on + ;;; top of comint mode. Cmushell mode is similar to, and intended to replace, + ;;; its counterpart in the standard gnu emacs release. This replacement is + ;;; more featureful, robust, and uniform than the released version. + + ;;; 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 cmushell mode, see the comments below. + + ;;; Needs fixin: + ;;; 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? + + (require 'comint) + (provide 'cmushell) + + ;; YOUR .EMACS FILE + ;;============================================================================= + ;; Some suggestions for your .emacs file. + ;; + ;; ; If cmushell lives in some non-standard directory, you must tell emacs + ;; ; where to get it. This may or may not be necessary. + ;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path)) + ;; + ;; ; Autoload cmushell from file cmushell.el + ;; (autoload 'cmushell "cmushell" + ;; "Run an inferior shell process." + ;; t) + ;; + ;; ; Define C-c C-t to run my favorite command in cmushell mode: + ;; (setq cmushell-load-hook + ;; '((lambda () + ;; (define-key cmushell-mode-map "\C-c\C-t" 'favorite-cmd)))) + + + ;;; Brief Command Documentation: + ;;;============================================================================ + ;;; Comint Mode Commands: (common to cmushell and all comint-derived modes) + ;;; + ;;; m-p comint-previous-input Cycle backwards in input history + ;;; m-n comint-next-input Cycle forwards + ;;; c-c r comint-previous-input-matching Search backwards in input history + ;;; return comint-send-input + ;;; c-a comint-bol Beginning of line; skip prompt. + ;;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff. + ;;; c-c c-u comint-kill-input ^u + ;;; c-c c-w backward-kill-word ^w + ;;; c-c c-c comint-interrupt-subjob ^c + ;;; c-c c-z comint-stop-subjob ^z + ;;; c-c c-\ comint-quit-subjob ^\ + ;;; c-c c-o comint-kill-output Delete last batch of process output + ;;; c-c c-r comint-show-output Show last batch of process output + ;;; send-invisible Read line w/o echo & send to proc + ;;; comint-continue-subjob Useful if you accidentally suspend + ;;; top-level job. + ;;; comint-mode-hook is the comint mode hook. + + ;;; Shell Mode Commands: + ;;; cmushell Fires up the shell process. + ;;; m-tab comint-dynamic-complete Complete a partial file name + ;;; m-? comint-dynamic-list-completions List completions in help buffer + ;;; dirs Resync the buffer's dir stack. + ;;; dirtrack-toggle Turn dir tracking on/off. + ;;; + ;;; The cmushell mode hook is cmushell-mode-hook + ;;; The cmushell-load-hook is run after this file is loaded. + ;;; comint-prompt-regexp is initialised to shell-prompt-pattern, for backwards + ;;; compatibility. + + ;;; Read the rest of this file for more information. + + ;;; SHELL.EL COMPATIBILITY + ;;;============================================================================ + ;;; In brief: this package should have no trouble coexisting with shell.el. + ;;; + ;;; Most customising variables -- e.g., explicit-shell-file-name -- are the + ;;; same, so the users shouldn't have much trouble. Hooks have different + ;;; names, however, so you can customise shell mode differently from cmushell + ;;; mode. You basically just have to remember to type M-x cmushell instead of + ;;; M-x shell. + ;;; + ;;; It would be nice if this file was completely plug-compatible with the old + ;;; shell package -- if you could just name this file shell.el, and have it + ;;; transparently replace the old one. But you can't. Several other packages + ;;; (tex-mode, background, dbx, gdb, kermit, monkey, prolog, telnet) are also + ;;; clients of shell mode. These packages assume detailed knowledge of shell + ;;; mode internals in ways that are incompatible with cmushell mode (mostly + ;;; because of cmushell mode's greater functionality). So, unless we are + ;;; willing to port all of these packages, we can't have this file be a + ;;; complete replacement for shell.el -- that is, we can't name this file + ;;; shell.el, and its main entry point (shell), because dbx.el will break + ;;; when it loads it in and tries to use it. + ;;; + ;;; There are two ways to fix this. One: rewrite these other modes to use the + ;;; new package. This is a win, but can't be assumed. The other, backwards + ;;; compatible route, is to make this package non-conflict with shell.el, so + ;;; both files can be loaded in at the same time. And *that* is why some + ;;; functions and variables have different names: (cmushell), + ;;; cmushell-mode-map, that sort of thing. All the names have been carefully + ;;; chosen so that shell.el and cmushell.el won't tromp on each other. + + ;;; Customisation and Buffer Variables + ;;; =========================================================================== + ;;; + + ;In loaddefs.el now. + ;(defconst shell-prompt-pattern + ; "^[^#$%>]*[#$%>] *" + ; "*Regexp used by Newline command to match subshell prompts. + ;;; Change the doc string for shell-prompt-pattern: + (put 'shell-prompt-pattern 'variable-documentation + "Regexp to match prompts in the inferior shell. + Defaults to \"^[^#$%>]*[#$%>] *\", which works pretty well. + This variable is used to initialise comint-prompt-regexp in the + shell buffer. + + This is a fine thing to set in your .emacs file.") + + (defvar shell-popd-regexp "popd" + "*Regexp to match subshell commands equivalent to popd.") + + (defvar shell-pushd-regexp "pushd" + "*Regexp to match subshell commands equivalent to pushd.") + + (defvar shell-cd-regexp "cd" + "*Regexp to match subshell commands equivalent to cd.") + + (defvar explicit-shell-file-name nil + "*If non-nil, is file name to use for explicitly requested inferior shell.") + + (defvar explicit-csh-args + (if (eq system-type 'hpux) + ;; -T persuades HP's csh not to think it is smarter + ;; than us about what terminal modes to use. + '("-i" "-T") + '("-i")) + "*Args passed to inferior shell by M-x cmushell, if the shell is csh. + Value is a list of strings, which may be nil.") + + ;;; All the above vars aren't prefixed "cmushell-" to make them + ;;; backwards compatible w/shell.el and old .emacs files. + + (defvar cmushell-dirstack nil + "List of directories saved by pushd in this buffer's shell.") + + (defvar cmushell-dirstack-query "dirs" + "Command used by shell-resync-dirlist to query shell.") + + (defvar cmushell-mode-map '()) + (cond ((not cmushell-mode-map) + (setq cmushell-mode-map (full-copy-sparse-keymap comint-mode-map)) + (define-key cmushell-mode-map "\M-\t" 'comint-dynamic-complete) + (define-key cmushell-mode-map "\M-?" 'comint-dynamic-list-completions))) + + (defvar cmushell-mode-hook '() + "*Hook for customising cmushell mode") + + + ;;; Basic Procedures + ;;; =========================================================================== + ;;; + + (defun cmushell-mode () + "Major mode for interacting with an inferior shell. + Return after the end of the process' output sends the text from the + end of process to the end of the current line. + Return before end of process output copies rest of line to end (skipping + the prompt) and sends it. + M-x send-invisible reads a line of text without echoing it, and sends it to + the shell. + + If you accidentally suspend your process, use \\[comint-continue-subjob] + to continue it. + + cd, pushd and popd commands given to the shell are watched by Emacs to keep + this buffer's default directory the same as the shell's working directory. + M-x dirs queries the shell and resyncs Emacs' idea of what the current + directory stack is. + M-x dirtrack-toggle turns directory tracking on and off. + + \\{cmushell-mode-map} + Customisation: Entry to this mode runs the hooks on comint-mode-hook and + cmushell-mode-hook (in that order). + + Variables shell-cd-regexp, shell-pushd-regexp and shell-popd-regexp are used + to match their respective commands." + (interactive) + (comint-mode) + (setq comint-prompt-regexp shell-prompt-pattern) + (setq major-mode 'cmushell-mode) + (setq mode-name "CMU shell") + (use-local-map cmushell-mode-map) + (make-local-variable 'cmushell-dirstack) + (setq cmushell-dirstack nil) + (make-local-variable 'cmushell-dirtrackp) + (setq cmushell-dirtrackp t) + (setq comint-input-sentinel 'cmushell-directory-tracker) + (run-hooks 'cmushell-mode-hook)) + + + (defun cmushell () + "Run an inferior shell, with I/O through buffer *cmushell*. + If buffer exists but shell process is not running, make new shell. + If buffer exists and shell process is running, + just switch to buffer *cmushell*. + Program used comes from variable explicit-shell-file-name, + or (if that is nil) from the ESHELL environment variable, + or else from SHELL if there is no ESHELL. + If a file ~/.emacs_SHELLNAME exists, it is given as initial input + (Note that this may lose due to a timing error if the shell + discards input when it starts up.) + The buffer is put in cmushell-mode, giving commands for sending input + and controlling the subjobs of the shell. See cmushell-mode. + See also variable shell-prompt-pattern. + + The shell file name (sans directories) is used to make a symbol name + such as `explicit-csh-arguments'. If that symbol is a variable, + its value is used as a list of arguments when invoking the shell. + Otherwise, one argument `-i' is passed to the shell. + + \(Type \\[describe-mode] in the shell buffer for a list of commands.)" + (interactive) + (cond ((not (comint-check-proc "*cmushell*")) + (let* ((prog (or explicit-shell-file-name + (getenv "ESHELL") + (getenv "SHELL") + "/bin/sh")) + (name (file-name-nondirectory prog)) + (startfile (concat "~/.emacs_" name)) + (xargs-name (intern-soft (concat "explicit-" name "-args")))) + (set-buffer (apply 'make-comint "cmushell" prog + (if (file-exists-p startfile) startfile) + (if (and xargs-name (boundp xargs-name)) + (symbol-value xargs-name) + '("-i")))) + (cmushell-mode)))) + (switch-to-buffer "*cmushell*")) + + + ;;; Directory tracking + ;;; =========================================================================== + ;;; This code provides the cmushell mode input sentinel + ;;; CMUSHELL-DIRECTORY-TRACKER + ;;; that tracks cd, pushd, and popd commands issued to the shell, and + ;;; changes the current directory of the shell buffer accordingly. + ;;; + ;;; This is basically a fragile hack, although it's more accurate than + ;;; the released version in shell.el. It has the following failings: + ;;; 1. It doesn't know about the cdpath shell variable. + ;;; 2. It only spots the first command in a command sequence. E.g., it will + ;;; miss the cd in "ls; cd foo" + ;;; 3. More generally, any complex command (like ";" sequencing) is going to + ;;; throw it. Otherwise, you'd have to build an entire shell interpreter in + ;;; emacs lisp. Failing that, there's no way to catch shell commands where + ;;; cd's are buried inside conditional expressions, aliases, and so forth. + ;;; + ;;; The whole approach is a crock. Shell aliases mess it up. File sourcing + ;;; messes it up. You run other processes under the shell; these each have + ;;; separate working directories, and some have commands for manipulating + ;;; their w.d.'s (e.g., the lcd command in ftp). Some of these programs have + ;;; commands that do *not* effect the current w.d. at all, but look like they + ;;; do (e.g., the cd command in ftp). In shells that allow you job + ;;; control, you can switch between jobs, all having different w.d.'s. So + ;;; simply saying %3 can shift your w.d.. + ;;; + ;;; The solution is to relax, not stress out about it, and settle for + ;;; a hack that works pretty well in typical circumstances. Remember + ;;; that a half-assed solution is more in keeping with the spirit of Unix, + ;;; anyway. Blech. + ;;; + ;;; One good hack not implemented here for users of programmable shells + ;;; is to program up the shell w.d. manipulation commands to output + ;;; a coded command sequence to the tty. Something like + ;;; ESC | | + ;;; where is the new current working directory. Then trash the + ;;; directory tracking machinery currently used in this package, and + ;;; replace it with a process filter that watches for and strips out + ;;; these messages. + + ;;; REGEXP is a regular expression. STR is a string. START is a fixnum. + ;;; Returns T if REGEXP matches STR where the match is anchored to start + ;;; at position START in STR. Sort of like LOOKING-AT for strings. + (defun cmushell-front-match (regexp str start) + (eq start (string-match regexp str start))) + + (defun cmushell-directory-tracker (str) + "Tracks cd, pushd and popd commands issued to the shell. + This function is called on each input passed to the shell. + It watches for cd, pushd and popd commands and sets the buffer's + default directory to track these commands. + + You may toggle this tracking on and off with M-x dirtrack-toggle. + If emacs gets confused, you can resync with the shell with M-x dirs. + + See variables shell-cd-regexp, shell-pushd-regexp, and shell-popd-regexp. + Environment variables are expanded, see function substitute-in-file-name." + (condition-case err + (cond (cmushell-dirtrackp + (string-match "^\\s *" str) ; skip whitespace + (let ((bos (match-end 0)) + (x nil)) + (cond ((setq x (cmushell-match-cmd-w/optional-arg shell-popd-regexp + str bos)) + (cmushell-process-popd (substitute-in-file-name x))) + ((setq x (cmushell-match-cmd-w/optional-arg shell-pushd-regexp + str bos)) + (cmushell-process-pushd (substitute-in-file-name x))) + ((setq x (cmushell-match-cmd-w/optional-arg shell-cd-regexp + str bos)) + (cmushell-process-cd (substitute-in-file-name x))))))) + (error (message (car (cdr err)))))) + + + ;;; Try to match regexp CMD to string, anchored at position START. + ;;; CMD may be followed by a single argument. If a match, then return + ;;; the argument, if there is one, or the empty string if not. If + ;;; no match, return nil. + + (defun cmushell-match-cmd-w/optional-arg (cmd str start) + (and (cmushell-front-match cmd str start) + (let ((eoc (match-end 0))) ; end of command + (cond ((cmushell-front-match "\\s *\\(\;\\|$\\)" str eoc) + "") ; no arg + ((cmushell-front-match "\\s +\\([^ \t\;]+\\)\\s *\\(\;\\|$\\)" + str eoc) + (substring str (match-beginning 1) (match-end 1))) ; arg + (t nil))))) ; something else. + ;;; The first regexp is [optional whitespace, (";" or the end of string)]. + ;;; The second regexp is [whitespace, (an arg), optional whitespace, + ;;; (";" or end of string)]. + + + ;;; popd [+n] + (defun cmushell-process-popd (arg) + (let ((num (if (zerop (length arg)) 0 ; no arg means +0 + (cmushell-extract-num arg)))) + (if (and num (< num (length cmushell-dirstack))) + (if (= num 0) ; condition-case because the CD could lose. + (condition-case nil (progn (cd (car cmushell-dirstack)) + (setq cmushell-dirstack + (cdr cmushell-dirstack)) + (cmushell-dirstack-message)) + (error (message "Couldn't cd."))) + (let* ((ds (cons nil cmushell-dirstack)) + (cell (nthcdr (- num 1) ds))) + (rplacd cell (cdr (cdr cell))) + (setq cmushell-dirstack (cdr ds)) + (cmushell-dirstack-message))) + (message "Bad popd.")))) + + + ;;; cd [dir] + (defun cmushell-process-cd (arg) + (condition-case nil (progn (cd (if (zerop (length arg)) (getenv "HOME") + arg)) + (cmushell-dirstack-message)) + (error (message "Couldn't cd.")))) + + + ;;; pushd [+n | dir] + (defun cmushell-process-pushd (arg) + (if (zerop (length arg)) + ;; no arg -- swap pwd and car of shell stack + (condition-case nil (if cmushell-dirstack + (let ((old default-directory)) + (cd (car cmushell-dirstack)) + (setq cmushell-dirstack + (cons old (cdr cmushell-dirstack))) + (cmushell-dirstack-message)) + (message "Directory stack empty.")) + (message "Couldn't cd.")) + + (let ((num (cmushell-extract-num arg))) + (if num ; pushd +n + (if (> num (length cmushell-dirstack)) + (message "Directory stack not that deep.") + (let* ((ds (cons default-directory cmushell-dirstack)) + (dslen (length ds)) + (front (nthcdr num ds)) + (back (reverse (nthcdr (- dslen num) (reverse ds)))) + (new-ds (append front back))) + (condition-case nil + (progn (cd (car new-ds)) + (setq cmushell-dirstack (cdr new-ds)) + (cmushell-dirstack-message)) + (error (message "Couldn't cd."))))) + + ;; pushd + (let ((old-wd default-directory)) + (condition-case nil + (progn (cd arg) + (setq cmushell-dirstack + (cons old-wd cmushell-dirstack)) + (cmushell-dirstack-message)) + (error (message "Couldn't cd.")))))))) + + ;; If STR is of the form +n, for n>0, return n. Otherwise, nil. + (defun cmushell-extract-num (str) + (and (string-match "^\\+[1-9][0-9]*$" str) + (string-to-int str))) + + + (defun cmushell-dirtrack-toggle () + "Turn directory tracking on and off in a cmushell buffer." + (interactive) + (setq cmushell-dirtrackp (not cmushell-dirtrackp)) + (message "directory tracking %s." + (if cmushell-dirtrackp "ON" "OFF"))) + + ;;; For your typing convenience: + (fset 'dirtrack-toggle 'cmushell-dirtrack-toggle) + + + (defun cmushell-resync-dirs () + "Resync the buffer's idea of the current directory stack. + This command queries the shell with the command bound to + cmushell-dirstack-query (default \"dirs\"), reads the next + line output and parses it to form the new directory stack. + DON'T issue this command unless the buffer is at a shell prompt. + Also, note that if some other subprocess decides to do output + immediately after the query, its output will be taken as the + new directory stack -- you lose. If this happens, just do the + command again." + (interactive) + (let* ((proc (get-buffer-process (current-buffer))) + (pmark (process-mark proc))) + (goto-char pmark) + (insert cmushell-dirstack-query) (insert "\n") + (sit-for 0) ; force redisplay + (comint-send-string proc cmushell-dirstack-query) + (comint-send-string proc "\n") + (set-marker pmark (point)) + (let ((pt (point))) ; wait for 1 line + ;; This extra newline prevents the user's pending input from spoofing us. + (insert "\n") (backward-char 1) + (while (not (looking-at ".+\n")) + (accept-process-output proc) + (goto-char pt))) + (goto-char pmark) (delete-char 1) ; remove the extra newline + ;; That's the dirlist. grab it & parse it. + (let* ((dl (buffer-substring (match-beginning 0) (- (match-end 0) 1))) + (dl-len (length dl)) + (ds '()) ; new dir stack + (i 0)) + (while (< i dl-len) + ;; regexp = optional whitespace, (non-whitespace), optional whitespace + (string-match "\\s *\\(\\S +\\)\\s *" dl i) ; pick off next dir + (setq ds (cons (substring dl (match-beginning 1) (match-end 1)) + ds)) + (setq i (match-end 0))) + (let ((ds (reverse ds))) + (condition-case nil + (progn (cd (car ds)) + (setq cmushell-dirstack (cdr ds)) + (cmushell-dirstack-message)) + (error (message "Couldn't cd."))))))) + + ;;; For your typing convenience: + (fset 'dirs 'cmushell-resync-dirs) + + + ;;; Show the current dirstack on the message line. + ;;; Pretty up dirs a bit by changing "/usr/jqr/foo" to "~/foo". + ;;; (This isn't necessary if the dirlisting is generated with a simple "dirs".) + ;;; All the commands that mung the buffer's dirstack finish by calling + ;;; this guy. + (defun cmushell-dirstack-message () + (let ((msg "") + (ds (cons default-directory cmushell-dirstack))) + (while ds + (let ((dir (car ds))) + (if (string-match (format "^%s\\(/\\|$\\)" (getenv "HOME")) dir) + (setq dir (concat "~/" (substring dir (match-end 0))))) + (if (string-equal dir "~/") (setq dir "~")) + (setq msg (concat msg dir " ")) + (setq ds (cdr ds)))) + (message msg))) + + + + ;;; Interfacing to client packages (and converting them) + ;;;============================================================================ + ;;; Several gnu packages (tex-mode, background, dbx, gdb, kermit, prolog, + ;;; telnet are some) use the shell package as clients. Most of them would + ;;; be better off using the comint package directly, but they predate it. + ;;; The catch is that most of these packages (dbx, gdb, prolog, telnet) + ;;; assume total knowledge of all the local variables that shell mode + ;;; functions depend on. So they (kill-all-local-variables), then create + ;;; the few local variables that shell.el functions depend on. Alas, + ;;; cmushell.el functions depend on a different set of vars (for example, + ;;; the input history ring is a local variable in cmushell.el's shell mode, + ;;; whereas there is no input history ring in shell.el's shell mode). + ;;; So we have a situation where the greater functionality of cmushell.el + ;;; is biting us -- you can't just replace shell will cmushell. + ;;; + ;;; Altering these packages to use comint mode directly should *greatly* + ;;; improve their functionality, and is actually pretty easy. It's + ;;; mostly a matter of renaming a few variable names. See comint.el for more. + ;;; -Olin + + + + ;;; Do the user's customisation... + ;;;=============================== + (defvar cmushell-load-hook nil + "This hook is run when cmushell is loaded in. + This is a good place to put keybindings.") + + (run-hooks 'cmushell-load-hook) + + ;;; Change Log + ;;; =========================================================================== + ;;; Olin 8/88 + ;;; Created. + ;;; + ;;; Olin 5/26/90 + ;;; - Split cmulisp and cmushell modes into separate files. + ;;; Not only is this a good idea, it's apparently the way it'll be rel 19. + ;;; - Souped up the directory tracking; it now can handle pushd, pushd +n, + ;;; and popd +n. + ;;; - Added cmushell-dirtrack-toggle command to toggle the directory + ;;; tracking that cmushell tries to do. This is useful, for example, + ;;; when you are running ftp -- it prevents the ftp "cd" command from + ;;; spoofing the tracking machinery. This command is also named + ;;; dirtrack-toggle, so you need only type M-x dirtrack to run it. + ;;; - Added cmushell-resync-dirs command. This queries the shell + ;;; for the current directory stack, and resets the buffer's stack + ;;; accordingly. This command is also named dirs, so you need only type + ;;; M-x dirs to run it. + ;;; - Bits of the new directory tracking code were adapted from source + ;;; contributed by Vince Broman, Jeff Peck, and Barry Warsaw. + ;;; - See also the improvements made to comint.el at the same time. + ;;; - Renamed several variables. Mostly this comprised changing "shell" + ;;; to "cmushell" in the names. The only variables that are not prefixed + ;;; with "cmushell-" are the ones that are common with shell.el: + ;;; explicit-shell-file-name shell-prompt-pattern explicit-csh-args + ;;; and shell-cd/popd/pushd-regexp + ;;; The variables and functions that were changed to have "cmushell-" + ;;; prefixes are: + ;;; shell-directory-stack (v), shell-directory-tracker (f) + ;;; This should not affect users, only elisp hackers. Hopefully + ;;; one day shell.el will just go away, and we can drop all this + ;;; "cmushell" bullshit. + ;;; - Upgraded process sends to use comint-send-string instead of + ;;; process-send-string. + ;;; + ;;; Olin 6/14/90 + ;;; - If your shell is named , and a variable named + ;;; explicit--args exists, cmushell is supposed + ;;; to use its value as the arglist to the shell invocation. + ;;; E.g., if you define explicit-csh-args to be + ;;; ("-ifx"), then when cmushell cranks up a csh, it execs it + ;;; as "csh -ifx". This is what is documented. What has actually + ;;; been the case is that the variable checked is + ;;; explicit--arguments, not explicit--args. + ;;; The documentation has been changed to conform to the code (for + ;;; backwards compatibility with shell.el). This bug is inherited from + ;;; the same bug in shell.el. + ;;; This bug reported by Stephen Anderson. + ;;; + ;;; Olin 9/5/90 + ;;; - Arguments to cd, popd, and pushd now have their env vars expanded + ;;; out by the tracking machinery. So if you say "cd $SRCDIR/funs", the + ;;; $SRCDIR var will be replaced by its value *in emacs' process + ;;; environment*. If this is different from the shell's binding of the + ;;; variable, you lose. Several users needed this feature, fragile + ;;; though it may be. The fix was contributed by sk@thp.Uni-Koeln.DE. *** /dev/null Thu Oct 31 13:46:09 1991 --- gnuemacs/comint-fix.DE Wed Oct 23 16:33:05 1991 *************** *** 0 **** --- 1,106 ---- + *** comint.el.orig Fri Aug 3 17:02:19 1990 + --- comint.el Tue Aug 7 18:53:16 1990 + *************** + *** 669,674 **** + --- 669,675 ---- + (interactive) + ;; Note that the input string does not include its terminal newline. + (let ((proc (get-buffer-process (current-buffer)))) + + (shell-completion-cleanup) + (if (not proc) (error "Current buffer has no process") + (let* ((pmark (process-mark proc)) + (pmark-val (marker-position pmark)) + *************** + *** 854,859 **** + --- 855,861 ---- + (defun comint-kill-input () + "Kill all text from last stuff output by interpreter to point." + (interactive) + + (shell-completion-cleanup) + (let* ((pmark (process-mark (get-buffer-process (current-buffer)))) + (p-pos (marker-position pmark))) + (if (> (point) p-pos) + *************** + *** 1166,1171 **** + --- 1168,1248 ---- + ; (global-set-key "\M-?" 'comint-dynamic-list-completions) + ; (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete) + + + ; Here is some new stuff that I have snarfed from Leonard N. Zubkoff. It is + + ; the file-name-completion stuff he did for shell mode. + + + + (defvar shell-completions-window nil + + "If non-nil, completion window requires cleaning up.") + + + + (defvar shell-token-pattern "[ \t\n()<>&|;]" + + "*Regexp used by shell name completion to mark path name boundries.") + + + + (defun shell-file-name-completion () + + "Preform file name completion in shell mode" + + (interactive) + + (let ((shell-expand-string nil) + + (shell-expand-begin nil) + + (shell-expand-end nil) + + (shell-expand-dir nil) + + (shell-expand-file nil) + + (shell-expand-completion nil)) + + + + ;; look back + + (re-search-backward shell-token-pattern nil t) + + (forward-char) + + (setq shell-expand-begin (point)) + + ;; look ahead + + (if (re-search-forward shell-token-pattern nil 0) (backward-char)) + + (setq shell-expand-end (point)) + + + + ;; the name requiring expansion + + (setq shell-expand-string + + (buffer-substring shell-expand-begin shell-expand-end)) + + ;; directory part of name + + (setq shell-expand-dir + + (or (file-name-directory shell-expand-string) default-directory)) + + ;; file part of name + + (setq shell-expand-file + + (file-name-nondirectory shell-expand-string)) + + + + ;; do the expansion + + (setq shell-expand-completion + + (file-name-completion shell-expand-file shell-expand-dir)) + + ;; display the results + + (if (eq shell-expand-completion t) (message "Sole completion") + + (if (eq shell-expand-completion nil) (message "No match") + + (if (equal shell-expand-completion shell-expand-file) + + (progn + + (if shell-completions-window nil + + (setq shell-completions-window + + (current-window-configuration))) + + (message "Making completion list...") + + (with-output-to-temp-buffer " *Completions*" + + (display-completion-list + + (sort (file-name-all-completions + + shell-expand-completion shell-expand-dir) + + 'string-lessp))) + + (message "")) + + ;; put in the expansion + + (search-backward shell-expand-file) + + (replace-match shell-expand-completion t t)))))) + + + + (defun shell-completion-cleanup () + + "Clean up windows after shell file name completion." + + (interactive) + + (if shell-completions-window + + (save-excursion + + (set-window-configuration shell-completions-window) + + (setq shell-completions-window nil)))) + + + + (defun kill-all-output-from-shell () + + "Kill shell buffer above current prompt." + + (interactive) + + (goto-char (point-max)) + + (re-search-backward shell-prompt-pattern nil t) + + (kill-region (point-min) (point)) + + (goto-char (point-max))) + + + ;;; Converting process modes to use comint mode + ;;; =========================================================================== + ;;; Several gnu packages (tex-mode, background, dbx, gdb, kermit, prolog, *** /dev/null Thu Oct 31 13:46:09 1991 --- gnuemacs/comint.el Wed Oct 23 16:33:07 1991 *************** *** 0 **** --- 1,1323 ---- + ;;; -*-Emacs-Lisp-*- General command interpreter in a window stuff + ;;; Copyright Olin Shivers (1988). + ;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright + ;;; notice appearing here to the effect that you may use this code any + ;;; way you like, as long as you don't charge money for it, remove this + ;;; notice, or hold me liable for its results. + + ;;; The changelog is at the end of this file. + + ;;; Please send me bug reports, bug fixes, and extensions, so that I can + ;;; merge them into the master source. + ;;; - Olin Shivers (shivers@cs.cmu.edu) + + ;;; This hopefully generalises shell mode, lisp mode, tea mode, soar mode,... + ;;; This file defines a general command-interpreter-in-a-buffer package + ;;; (comint mode). The idea is that you can build specific process-in-a-buffer + ;;; modes on top of comint mode -- e.g., lisp, shell, scheme, T, soar, .... + ;;; This way, all these specific packages share a common base functionality, + ;;; and a common set of bindings, which makes them easier to use (and + ;;; saves code, implementation time, etc., etc.). + + ;;; Several packages are already defined using comint mode: + ;;; - cmushell.el defines a shell-in-a-buffer mode. + ;;; - cmulisp.el defines a simple lisp-in-a-buffer mode. + ;;; Cmushell and cmulisp mode are similar to, and intended to replace, + ;;; their counterparts in the standard gnu emacs release (in shell.el). + ;;; These replacements are more featureful, robust, and uniform than the + ;;; released versions. The key bindings in lisp mode are also more compatible + ;;; with the bindings of Hemlock and Zwei (the Lisp Machine emacs). + ;;; + ;;; - The file cmuscheme.el defines a scheme-in-a-buffer mode. + ;;; - The file tea.el tunes scheme and inferior-scheme modes for T. + ;;; - The file soar.el tunes lisp and inferior-lisp modes for Soar. + ;;; - cmutex.el defines tex and latex modes that invoke tex, latex, bibtex, + ;;; previewers, and printers from within emacs. + ;;; - background.el allows csh-like job control inside emacs. + ;;; It is pretty easy to make new derived modes for other processes. + + ;;; For documentation on the functionality provided by comint mode, and + ;;; the hooks available for customising it, see the comments below. + ;;; For further information on the standard derived modes (shell, + ;;; inferior-lisp, inferior-scheme, ...), see the relevant source files. + + ;;; For hints on converting existing process modes (e.g., tex-mode, + ;;; background, dbx, gdb, kermit, prolog, telnet) to use comint-mode + ;;; instead of shell-mode, see the notes at the end of this file. + + (provide 'comint) + (defconst comint-version "2.01") + + + ;;; Brief Command Documentation: + ;;;============================================================================ + ;;; Comint Mode Commands: (common to all derived modes, like cmushell & cmulisp + ;;; mode) + ;;; + ;;; m-p comint-previous-input Cycle backwards in input history + ;;; m-n comint-next-input Cycle forwards + ;;; m-s comint-previous-similar-input Previous similar input + ;;; c-c r comint-previous-input-matching Search backwards in input history + ;;; return comint-send-input + ;;; c-a comint-bol Beginning of line; skip prompt. + ;;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff. + ;;; c-c c-u comint-kill-input ^u + ;;; c-c c-w backward-kill-word ^w + ;;; c-c c-c comint-interrupt-subjob ^c + ;;; c-c c-z comint-stop-subjob ^z + ;;; c-c c-\ comint-quit-subjob ^\ + ;;; c-c c-o comint-kill-output Delete last batch of process output + ;;; c-c c-r comint-show-output Show last batch of process output + ;;; + ;;; Not bound by default in comint-mode + ;;; send-invisible Read a line w/o echo, and send to proc + ;;; (These are bound in shell-mode) + ;;; comint-dynamic-complete Complete filename at point. + ;;; comint-dynamic-list-completions List completions in help buffer. + ;;; comint-replace-by-expanded-filename Expand and complete filename at point; + ;;; replace with expanded/completed name. + ;;; comint-kill-subjob No mercy. + ;;; comint-continue-subjob Send CONT signal to buffer's process + ;;; group. Useful if you accidentally + ;;; suspend your process (with C-c C-z). + ;;; + ;;; Bound for RMS -- I prefer the input history stuff, but you might like 'em. + ;;; m-P comint-msearch-input Search backwards for prompt + ;;; m-N comint-psearch-input Search forwards for prompt + ;;; C-cR comint-msearch-input-matching Search backwards for prompt & string + + ;;; comint-mode-hook is the comint mode hook. Basically for your keybindings. + ;;; comint-load-hook is run after loading in this package. + + + ;;; Buffer Local Variables: + ;;;============================================================================ + ;;; Comint mode buffer local variables: + ;;; comint-prompt-regexp - string comint-bol uses to match prompt. + ;;; comint-last-input-end - marker For comint-kill-output command + ;;; input-ring-size - integer For the input history + ;;; input-ring - ring mechanism + ;;; input-ring-index - marker ... + ;;; comint-last-input-match - string ... + ;;; comint-get-old-input - function Hooks for specific + ;;; comint-input-sentinel - function process-in-a-buffer + ;;; comint-input-filter - function modes. + ;;; comint-input-send - function + ;;; comint-eol-on-send - boolean + + (defvar comint-prompt-regexp "^" + "Regexp to recognise prompts in the inferior process. + Defaults to \"^\", the null string at BOL. + + Good choices: + Canonical Lisp: \"^[^> ]*>+:? *\" (Lucid, franz, kcl, T, cscheme, oaklisp) + Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\" + franz: \"^\\(->\\|<[0-9]*>:\\) *\" + kcl: \"^>+ *\" + shell: \"^[^#$%>]*[#$%>] *\" + T: \"^>+ *\" + + This is a good thing to set in mode hooks.") + + (defvar input-ring-size 30 + "Size of input history ring.") + + ;;; Here are the per-interpreter hooks. + (defvar comint-get-old-input (function comint-get-old-input-default) + "Function that submits old text in comint mode. + This function is called when return is typed while the point is in old text. + It returns the text to be submitted as process input. The default is + comint-get-old-input-default, which grabs the current line, and strips off + leading text matching comint-prompt-regexp") + + (defvar comint-input-sentinel (function ignore) + "Called on each input submitted to comint mode process by comint-send-input. + Thus it can, for instance, track cd/pushd/popd commands issued to the csh.") + + (defvar comint-input-filter + (function (lambda (str) (not (string-match "\\`\\s *\\'" str)))) + "Predicate for filtering additions to input history. + Only inputs answering true to this function are saved on the input + history list. Default is to save anything that isn't all whitespace") + + (defvar comint-input-sender (function comint-simple-send) + "Function to actually send to PROCESS the STRING submitted by user. + Usually this is just 'comint-simple-send, but if your mode needs to + massage the input string, this is your hook. This is called from + the user command comint-send-input. comint-simple-send just sends + the string plus a newline.") + + (defvar comint-eol-on-send 'T + "If non-nil, then jump to the end of the line before sending input to process. + See COMINT-SEND-INPUT") + + (defvar comint-mode-hook '() + "Called upon entry into comint-mode") + + (defvar comint-mode-map nil) + + (defun comint-mode () + "Major mode for interacting with an inferior interpreter. + Interpreter name is same as buffer name, sans the asterisks. + Return at end of buffer sends line as input. + Return not at end copies rest of line to end and sends it. + Setting mode variable comint-eol-on-send means jump to the end of the line + before submitting new input. + + This mode is typically customised to create inferior-lisp-mode, + shell-mode, etc.. This can be done by setting the hooks + comint-input-sentinel, comint-input-filter, comint-input-sender and + comint-get-old-input to appropriate functions, and the variable + comint-prompt-regexp to the appropriate regular expression. + + An input history is maintained of size input-ring-size, and + can be accessed with the commands comint-next-input [\\[comint-next-input]] and + comint-previous-input [\\[comint-previous-input]]. Commands not keybound by + default are send-invisible, comint-dynamic-complete, and + comint-list-dynamic-completions. + + If you accidentally suspend your process, use \\[comint-continue-subjob] + to continue it. + + \\{comint-mode-map} + + Entry to this mode runs the hooks on comint-mode-hook" + (interactive) + (let ((old-ring (and (assq 'input-ring (buffer-local-variables)) + (boundp 'input-ring) + input-ring)) + (old-ptyp comint-ptyp)) ; preserve across local var kill. gross. + (kill-all-local-variables) + (setq major-mode 'comint-mode) + (setq mode-name "Comint") + (setq mode-line-process '(": %s")) + (use-local-map comint-mode-map) + (make-local-variable 'comint-last-input-end) + (setq comint-last-input-end (make-marker)) + (make-local-variable 'comint-last-input-match) + (setq comint-last-input-match "") + (make-local-variable 'comint-prompt-regexp) ; Don't set; default + (make-local-variable 'input-ring-size) ; ...to global val. + (make-local-variable 'input-ring) + (make-local-variable 'input-ring-index) + (setq input-ring-index 0) + (make-local-variable 'comint-get-old-input) + (make-local-variable 'comint-input-sentinel) + (make-local-variable 'comint-input-filter) + (make-local-variable 'comint-input-sender) + (make-local-variable 'comint-eol-on-send) + (make-local-variable 'comint-ptyp) + (setq comint-ptyp old-ptyp) + (run-hooks 'comint-mode-hook) + ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook. + ;The test is so we don't lose history if we run comint-mode twice in + ;a buffer. + (setq input-ring (if (ring-p old-ring) old-ring + (make-ring input-ring-size))))) + + ;;; The old-ptyp stuff above is because we have to preserve the value of + ;;; comint-ptyp across calls to comint-mode, in spite of the + ;;; kill-all-local-variables that it does. Blech. Hopefully, this will all + ;;; go away when a later release fixes the signalling bug. + + (if comint-mode-map + nil + (setq comint-mode-map (make-sparse-keymap)) + (define-key comint-mode-map "\ep" 'comint-previous-input) + (define-key comint-mode-map "\en" 'comint-next-input) + (define-key comint-mode-map "\es" 'comint-previous-similar-input) + (define-key comint-mode-map "\C-m" 'comint-send-input) + (define-key comint-mode-map "\C-d" 'comint-delchar-or-maybe-eof) + (define-key comint-mode-map "\C-a" 'comint-bol) + (define-key comint-mode-map "\C-c\C-u" 'comint-kill-input) + (define-key comint-mode-map "\C-c\C-w" 'backward-kill-word) + (define-key comint-mode-map "\C-c\C-c" 'comint-interrupt-subjob) + (define-key comint-mode-map "\C-c\C-z" 'comint-stop-subjob) + (define-key comint-mode-map "\C-c\C-\\" 'comint-quit-subjob) + (define-key comint-mode-map "\C-c\C-o" 'comint-kill-output) + (define-key comint-mode-map "\C-cr" 'comint-previous-input-matching) + (define-key comint-mode-map "\C-c\C-r" 'comint-show-output) + ;;; Here's the prompt-search stuff I installed for RMS to try... + (define-key comint-mode-map "\eP" 'comint-msearch-input) + (define-key comint-mode-map "\eN" 'comint-psearch-input) + (define-key comint-mode-map "\C-cR" 'comint-msearch-input-matching)) + + + ;;; This function is used to make a full copy of the comint mode map, + ;;; so that client modes won't interfere with each other. This function + ;;; isn't necessary in emacs 18.5x, but we keep it around for 18.4x versions. + (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))) + + (defun comint-check-proc (buffer-name) + "True if there is a process associated w/buffer BUFFER-NAME, and + it is alive (status RUN or STOP)." + (let ((proc (get-buffer-process buffer-name))) + (and proc (memq (process-status proc) '(run stop))))) + + ;;; Note that this guy, unlike shell.el's make-shell, barfs if you pass it () + ;;; for the second argument (program). + (defun make-comint (name program &optional startfile &rest switches) + (let* ((buffer (get-buffer-create (concat "*" name "*"))) + (proc (get-buffer-process buffer))) + ;; If no process, or nuked process, crank up a new one and put buffer in + ;; comint mode. Otherwise, leave buffer and existing process alone. + (cond ((or (not proc) (not (memq (process-status proc) '(run stop)))) + (save-excursion + (set-buffer buffer) + (comint-mode)) ; Install local vars, mode, keymap, ... + (comint-exec buffer name program startfile switches))) + buffer)) + + (defvar comint-ptyp t + "True if communications via pty; false if by pipe. Buffer local. + This is to work around a bug in emacs process signalling.") + + (defun comint-exec (buffer name command startfile switches) + "Fires up a process in buffer for comint modes. + Blasts any old process running in the buffer. Doesn't set the buffer mode. + You can use this to cheaply run a series of processes in the same comint + buffer." + (save-excursion + (set-buffer buffer) + (let ((proc (get-buffer-process buffer))) ; Blast any old process. + (if proc (delete-process proc))) + ;; Crank up a new process + (let ((proc (comint-exec-1 name buffer command switches))) + (make-local-variable 'comint-ptyp) + (setq comint-ptyp process-connection-type) ; T if pty, NIL if pipe. + ;; Jump to the end, and set the process mark. + (goto-char (point-max)) + (set-marker (process-mark proc) (point))) + ;; Feed it the startfile. + (cond (startfile + ;;This is guaranteed to wait long enough + ;;but has bad results if the comint does not prompt at all + ;; (while (= size (buffer-size)) + ;; (sleep-for 1)) + ;;I hope 1 second is enough! + (sleep-for 1) + (goto-char (point-max)) + (insert-file-contents startfile) + (setq startfile (buffer-substring (point) (point-max))) + (delete-region (point) (point-max)) + (comint-send-string proc startfile))) + buffer)) + + ;;; This auxiliary function cranks up the process for comint-exec in + ;;; the appropriate environment. It is twice as long as it should be + ;;; because emacs has two distinct mechanisms for manipulating the + ;;; process environment, selected at compile time with the + ;;; MAINTAIN-ENVIRONMENT #define. In one case, process-environment + ;;; is bound; in the other it isn't. + + (defun comint-exec-1 (name buffer command switches) + (if (boundp 'process-environment) ; Not a completely reliable test. + (let ((process-environment + (comint-update-env process-environment + (list (format "TERMCAP=emacs:co#%d:tc=unknown" + (screen-width)) + "TERM=emacs" + "EMACS=t")))) + (apply 'start-process name buffer command switches)) + + (let ((tcapv (getenv "TERMCAP")) + (termv (getenv "TERM")) + (emv (getenv "EMACS"))) + (unwind-protect + (progn (setenv "TERMCAP" (format "emacs:co#%d:tc=unknown" + (screen-width))) + (setenv "TERM" "emacs") + (setenv "EMACS" "t") + (apply 'start-process name buffer command switches)) + (setenv "TERMCAP" tcapv) + (setenv "TERM" termv) + (setenv "EMACS" emv))))) + + + + ;; This is just (append new old-env) that compresses out shadowed entries. + ;; It's also pretty ugly, mostly due to elisp's horrible iteration structures. + (defun comint-update-env (old-env new) + (let ((ans (reverse new)) + (vars (mapcar (function (lambda (vv) + (and (string-match "^[^=]*=" vv) + (substring vv 0 (match-end 0))))) + new))) + (while old-env + (let* ((vv (car old-env)) ; vv is var=value + (var (and (string-match "^[^=]*=" vv) + (substring vv 0 (match-end 0))))) + (setq old-env (cdr old-env)) + (cond ((not (and var (comint-mem var vars))) + (if var (setq var (cons var vars))) + (setq ans (cons vv ans)))))) + (nreverse ans))) + + ;;; This should be in emacs, but it isn't. + (defun comint-mem (item list &optional elt=) + "Test to see if ITEM is equal to an item in LIST. + Option comparison function ELT= defaults to equal." + (let ((elt= (or elt= (function equal))) + (done nil)) + (while (and list (not done)) + (if (funcall elt= item (car list)) + (setq done list) + (setq list (cdr list)))) + done)) + + + ;;; Ring Code + ;;;============================================================================ + ;;; This code defines a ring data structure. A ring is a + ;;; (hd-index tl-index . vector) + ;;; list. You can insert to, remove from, and rotate a ring. When the ring + ;;; fills up, insertions cause the oldest elts to be quietly dropped. + ;;; + ;;; HEAD = index of the newest item on the ring. + ;;; TAIL = index of the oldest item on the ring. + ;;; + ;;; These functions are used by the input history mechanism, but they can + ;;; be used for other purposes as well. + + (defun ring-p (x) + "T if X is a ring; NIL otherwise." + (and (consp x) (integerp (car x)) + (consp (cdr x)) (integerp (car (cdr x))) + (vectorp (cdr (cdr x))))) + + (defun make-ring (size) + "Make a ring that can contain SIZE elts" + (cons 1 (cons 0 (make-vector (+ size 1) nil)))) + + (defun ring-plus1 (index veclen) + "INDEX+1, with wraparound" + (let ((new-index (+ index 1))) + (if (= new-index veclen) 0 new-index))) + + (defun ring-minus1 (index veclen) + "INDEX-1, with wraparound" + (- (if (= 0 index) veclen index) 1)) + + (defun ring-length (ring) + "Number of elts in the ring." + (let ((hd (car ring)) (tl (car (cdr ring))) (siz (length (cdr (cdr ring))))) + (let ((len (if (<= hd tl) (+ 1 (- tl hd)) (+ 1 tl (- siz hd))))) + (if (= len siz) 0 len)))) + + (defun ring-empty-p (ring) + (= 0 (ring-length ring))) + + (defun ring-insert (ring item) + "Insert a new item onto the ring. If the ring is full, dump the oldest + item to make room." + (let* ((vec (cdr (cdr ring))) (len (length vec)) + (new-hd (ring-minus1 (car ring) len))) + (setcar ring new-hd) + (aset vec new-hd item) + (if (ring-empty-p ring) ;overflow -- dump one off the tail. + (setcar (cdr ring) (ring-minus1 (car (cdr ring)) len))))) + + (defun ring-remove (ring) + "Remove the oldest item retained on the ring." + (if (ring-empty-p ring) (error "Ring empty") + (let ((tl (car (cdr ring))) (vec (cdr (cdr ring)))) + (set-car (cdr ring) (ring-minus1 tl (length vec))) + (aref vec tl)))) + + ;;; This isn't actually used in this package. I just threw it in in case + ;;; someone else wanted it. If you want rotating-ring behavior on your history + ;;; retrieval (analagous to kill ring behavior), this function is what you + ;;; need. I should write the yank-input and yank-pop-input-or-kill to go with + ;;; this, and not bind it to a key by default, so it would be available to + ;;; people who want to bind it to a key. But who would want it? Blech. + (defun ring-rotate (ring n) + (if (not (= n 0)) + (if (ring-empty-p ring) ;Is this the right error check? + (error "ring empty") + (let ((hd (car ring)) (tl (car (cdr ring))) (vec (cdr (cdr ring)))) + (let ((len (length vec))) + (while (> n 0) + (setq tl (ring-plus1 tl len)) + (aset ring tl (aref ring hd)) + (setq hd (ring-plus1 hd len)) + (setq n (- n 1))) + (while (< n 0) + (setq hd (ring-minus1 hd len)) + (aset vec hd (aref vec tl)) + (setq tl (ring-minus1 tl len)) + (setq n (- n 1)))) + (set-car ring hd) + (set-car (cdr ring) tl))))) + + (defun comint-mod (n m) + "Returns N mod M. M is positive. Answer is guaranteed to be non-negative, + and less than m." + (let ((n (% n m))) + (if (>= n 0) n + (+ n + (if (>= m 0) m (- m)))))) ; (abs m) + + (defun ring-ref (ring index) + (let ((numelts (ring-length ring))) + (if (= numelts 0) (error "indexed empty ring") + (let* ((hd (car ring)) (tl (car (cdr ring))) (vec (cdr (cdr ring))) + (index (comint-mod index numelts)) + (vec-index (comint-mod (+ index hd) + (length vec)))) + (aref vec vec-index))))) + + + ;;; Input history retrieval commands + ;;; M-p -- previous input M-n -- next input + ;;; C-c r -- previous input matching + ;;; =========================================================================== + + (defun comint-previous-input (arg) + "Cycle backwards through input history." + (interactive "*p") + (let ((len (ring-length input-ring))) + (cond ((<= len 0) + (message "Empty input ring") + (ding)) + ((not (comint-after-pmark-p)) + (message "Not after process mark") + (ding)) + (t + (cond ((eq last-command 'comint-previous-input) + (delete-region (mark) (point))) + ((eq last-command 'comint-previous-similar-input) + (delete-region + (process-mark (get-buffer-process (current-buffer))) + (point))) + (t + (setq input-ring-index + (if (> arg 0) -1 + (if (< arg 0) 1 0))) + (push-mark (point)))) + (setq input-ring-index (comint-mod (+ input-ring-index arg) len)) + (message "%d" (1+ input-ring-index)) + (insert (ring-ref input-ring input-ring-index)) + (setq this-command 'comint-previous-input))))) + + (defun comint-next-input (arg) + "Cycle forwards through input history." + (interactive "*p") + (comint-previous-input (- arg))) + + (defvar comint-last-input-match "" + "Last string searched for by comint input history search, for defaulting. + Buffer local variable.") + + (defun comint-previous-input-matching (str) + "Searches backwards through input history for substring match." + (interactive (let* ((last-command last-command) ; preserve around r-f-m + (s (read-from-minibuffer + (format "Command substring (default %s): " + comint-last-input-match)))) + (list (if (string= s "") comint-last-input-match s)))) + ; (interactive "sCommand substring: ") + (setq comint-last-input-match str) ; update default + (if (not (eq last-command 'comint-previous-input)) + (setq input-ring-index -1)) + (let ((str (regexp-quote str)) + (len (ring-length input-ring)) + (n (+ input-ring-index 1))) + (while (and (< n len) (not (string-match str (ring-ref input-ring n)))) + (setq n (+ n 1))) + (cond ((< n len) + (comint-previous-input (- n input-ring-index))) + (t (if (eq last-command 'comint-previous-input) + (setq this-command 'comint-previous-input)) + (message "Not found.") + (ding))))) + + + ;;; These next three commands are alternatives to the input history commands -- + ;;; comint-next-input, comint-previous-input and + ;;; comint-previous-input-matching. They search through the process buffer + ;;; text looking for occurrences of the prompt. RMS likes them better; + ;;; I don't. Bound to M-P, M-N, and C-c R (uppercase P, N, and R) for + ;;; now. Try'em out. Go with what you like... + + ;;; comint-msearch-input-matching prompts for a string, not a regexp. + ;;; This could be considered to be the wrong thing. I decided to keep it + ;;; simple, and not make the user worry about regexps. This, of course, + ;;; limits functionality. + + (defun comint-psearch-input () + "Search forwards for next occurrence of prompt and skip to end of line. + \(prompt is anything matching regexp comint-prompt-regexp)" + (interactive) + (if (re-search-forward comint-prompt-regexp (point-max) t) + (end-of-line) + (error "No occurrence of prompt found"))) + + (defun comint-msearch-input () + "Search backwards for previous occurrence of prompt and skip to end of line. + Search starts from beginning of current line." + (interactive) + (let ((p (save-excursion + (beginning-of-line) + (cond ((re-search-backward comint-prompt-regexp (point-min) t) + (end-of-line) + (point)) + (t nil))))) + (if p (goto-char p) + (error "No occurrence of prompt found")))) + + (defun comint-msearch-input-matching (str) + "Search backwards for occurrence of prompt followed by STRING. + STRING is prompted for, and is NOT a regular expression." + (interactive (let ((s (read-from-minibuffer + (format "Command (default %s): " + comint-last-input-match)))) + (list (if (string= s "") comint-last-input-match s)))) + ; (interactive "sCommand: ") + (setq comint-last-input-match str) ; update default + (let* ((r (concat comint-prompt-regexp (regexp-quote str))) + (p (save-excursion + (beginning-of-line) + (cond ((re-search-backward r (point-min) t) + (end-of-line) + (point)) + (t nil))))) + (if p (goto-char p) + (error "No match")))) + + ;;; + ;;; Similar input -- contributed by ccm and highly winning. + ;;; + ;;; Reenter input, removing back to the last insert point if it exists. + ;;; + (defvar comint-last-similar-string "" + "The string last used in a similar string search.") + (defun comint-previous-similar-input (arg) + "Reenters the last input that matches the string typed so far. If repeated + successively older inputs are reentered. If arg is 1, it will go back + in the history, if -1 it will go forward." + (interactive "p") + (if (not (comint-after-pmark-p)) + (error "Not after process mark")) + (if (not (eq last-command 'comint-previous-similar-input)) + (setq input-ring-index -1 + comint-last-similar-string + (buffer-substring + (process-mark (get-buffer-process (current-buffer))) + (point)))) + (let* ((size (length comint-last-similar-string)) + (len (ring-length input-ring)) + (n (+ input-ring-index arg)) + entry) + (while (and (< n len) + (or (< (length (setq entry (ring-ref input-ring n))) size) + (not (equal comint-last-similar-string + (substring entry 0 size))))) + (setq n (+ n arg))) + (cond ((< n len) + (setq input-ring-index n) + (if (eq last-command 'comint-previous-similar-input) + (delete-region (mark) (point)) ; repeat + (push-mark (point))) ; 1st time + (insert (substring entry size))) + (t (message "Not found.") (ding) (sit-for 1))) + (message "%d" (1+ input-ring-index)))) + + + (defun comint-send-input () + "Send input to process. After the process output mark, sends all text + from the process mark to point as input to the process. Before the + process output mark, calls value of variable comint-get-old-input to retrieve + old input, copies it to the end of the buffer, and sends it. A terminal + newline is also inserted into the buffer and sent to the process. In either + case, value of variable comint-input-sentinel is called on the input before + sending it. The input is entered into the input history ring, if value of + variable comint-input-filter returns non-nil when called on the input. + + If variable comint-eol-on-send is non-nil, then point is moved to the end of + line before sending the input. + + comint-get-old-input, comint-input-sentinel, and comint-input-filter are chosen + according to the command interpreter running in the buffer. E.g., + If the interpreter is the csh, + comint-get-old-input is the default: take the current line, discard any + initial string matching regexp comint-prompt-regexp. + comint-input-sentinel monitors input for \"cd\", \"pushd\", and \"popd\" + commands. When it sees one, it cd's the buffer. + comint-input-filter is the default: returns T if the input isn't all white + space. + + If the comint is Lucid Common Lisp, + comint-get-old-input snarfs the sexp ending at point. + comint-input-sentinel does nothing. + comint-input-filter returns NIL if the input matches input-filter-regexp, + which matches (1) all whitespace (2) :a, :c, etc. + + Similarly for Soar, Scheme, etc.." + (interactive) + ;; Note that the input string does not include its terminal newline. + (let ((proc (get-buffer-process (current-buffer)))) + (if (not proc) (error "Current buffer has no process") + (let* ((pmark (process-mark proc)) + (pmark-val (marker-position pmark)) + (input (if (>= (point) pmark-val) + (progn (if comint-eol-on-send (end-of-line)) + (buffer-substring pmark (point))) + (let ((copy (funcall comint-get-old-input))) + (goto-char pmark) + (insert copy) + copy)))) + (insert ?\n) + (if (funcall comint-input-filter input) (ring-insert input-ring input)) + (funcall comint-input-sentinel input) + (funcall comint-input-sender proc input) + (set-marker (process-mark proc) (point)) + (set-marker comint-last-input-end (point)))))) + + (defun comint-get-old-input-default () + "Default for comint-get-old-input: take the current line, and discard + any initial text matching comint-prompt-regexp." + (save-excursion + (beginning-of-line) + (comint-skip-prompt) + (let ((beg (point))) + (end-of-line) + (buffer-substring beg (point))))) + + (defun comint-skip-prompt () + "Skip past the text matching regexp comint-prompt-regexp. + If this takes us past the end of the current line, don't skip at all." + (let ((eol (save-excursion (end-of-line) (point)))) + (if (and (looking-at comint-prompt-regexp) + (<= (match-end 0) eol)) + (goto-char (match-end 0))))) + + + (defun comint-after-pmark-p () + "Is point after the process output marker?" + ;; Since output could come into the buffer after we looked at the point + ;; but before we looked at the process marker's value, we explicitly + ;; serialise. This is just because I don't know whether or not emacs + ;; services input during execution of lisp commands. + (let ((proc-pos (marker-position + (process-mark (get-buffer-process (current-buffer)))))) + (<= proc-pos (point)))) + + (defun comint-simple-send (proc string) + "Default function for sending to PROC input STRING. + This just sends STRING plus a newline. To override this, + set the hook COMINT-INPUT-SENDER." + (comint-send-string proc string) + (comint-send-string proc "\n")) + + (defun comint-bol (arg) + "Goes to the beginning of line, then skips past the prompt, if any. + If a prefix argument is given (\\[universal-argument]), then no prompt skip + -- go straight to column 0. + + The prompt skip is done by skipping text matching the regular expression + comint-prompt-regexp, a buffer local variable. + + If you don't like this command, reset c-a to beginning-of-line + in your hook, comint-mode-hook." + (interactive "P") + (beginning-of-line) + (if (null arg) (comint-skip-prompt))) + + ;;; These two functions are for entering text you don't want echoed or + ;;; saved -- typically passwords to ftp, telnet, or somesuch. + ;;; Just enter m-x send-invisible and type in your line. + + (defun comint-read-noecho (prompt) + "Prompt the user with argument PROMPT. Read a single line of text + without echoing, and return it. Note that the keystrokes comprising + the text can still be recovered (temporarily) with \\[view-lossage]. This + may be a security bug for some applications." + (let ((echo-keystrokes 0) + (answ "") + tem) + (if (and (stringp prompt) (not (string= (message prompt) ""))) + (message prompt)) + (while (not(or (= (setq tem (read-char)) ?\^m) + (= tem ?\n))) + (setq answ (concat answ (char-to-string tem)))) + (message "") + answ)) + + (defun send-invisible (str) + "Read a string without echoing, and send it to the process running + in the current buffer. A new-line is additionally sent. String is not + saved on comint input history list. + Security bug: your string can still be temporarily recovered with + \\[view-lossage]." + ; (interactive (list (comint-read-noecho "Enter non-echoed text"))) + (interactive "P") ; Defeat snooping via C-x esc + (let ((proc (get-buffer-process (current-buffer)))) + (if (not proc) (error "Current buffer has no process") + (comint-send-string proc + (if (stringp str) str + (comint-read-noecho "Enter non-echoed text"))) + (comint-send-string proc "\n")))) + + + ;;; Low-level process communication + + (defvar comint-input-chunk-size 512 + "*Long inputs send to comint processes are broken up into chunks of this size. + If your process is choking on big inputs, try lowering the value.") + + (defun comint-send-string (proc str) + "Send PROCESS the contents of STRING as input. + This is equivalent to process-send-string, except that long input strings + are broken up into chunks of size comint-input-chunk-size. Processes + are given a chance to output between chunks. This can help prevent processes + from hanging when you send them long inputs on some OS's." + (let* ((len (length str)) + (i (min len comint-input-chunk-size))) + (process-send-string proc (substring str 0 i)) + (while (< i len) + (let ((next-i (+ i comint-input-chunk-size))) + (accept-process-output) + (process-send-string proc (substring str i (min len next-i))) + (setq i next-i))))) + + (defun comint-send-region (proc start end) + "Sends to PROC the region delimited by START and END. + This is a replacement for process-send-region that tries to keep + your process from hanging on long inputs. See comint-send-string." + (comint-send-string proc (buffer-substring start end))) + + + ;;; Random input hackage + + (defun comint-kill-output () + "Kill all output from interpreter since last input." + (interactive) + (let ((pmark (process-mark (get-buffer-process (current-buffer))))) + (kill-region comint-last-input-end pmark) + (goto-char pmark) + (insert "*** output flushed ***\n") + (set-marker pmark (point)))) + + (defun comint-show-output () + "Display start of this batch of interpreter output at top of window. + Also put cursor there." + (interactive) + (goto-char comint-last-input-end) + (backward-char) + (beginning-of-line) + (set-window-start (selected-window) (point)) + (end-of-line)) + + (defun comint-interrupt-subjob () + "Interrupt the current subjob." + (interactive) + (interrupt-process nil comint-ptyp)) + + (defun comint-kill-subjob () + "Send kill signal to the current subjob." + (interactive) + (kill-process nil comint-ptyp)) + + (defun comint-quit-subjob () + "Send quit signal to the current subjob." + (interactive) + (quit-process nil comint-ptyp)) + + (defun comint-stop-subjob () + "Stop the current subjob. + WARNING: if there is no current subjob, you can end up suspending + the top-level process running in the buffer. If you accidentally do + this, use \\[comint-continue-subjob] to resume the process. (This + is not a problem with most shells, since they ignore this signal.)" + (interactive) + (stop-process nil comint-ptyp)) + + (defun comint-continue-subjob () + "Send CONT signal to process buffer's process group. + Useful if you accidentally suspend the top-level process." + (interactive) + (continue-process nil comint-ptyp)) + + (defun comint-kill-input () + "Kill all text from last stuff output by interpreter to point." + (interactive) + (let* ((pmark (process-mark (get-buffer-process (current-buffer)))) + (p-pos (marker-position pmark))) + (if (> (point) p-pos) + (kill-region pmark (point))))) + + (defun comint-delchar-or-maybe-eof (arg) + "Delete ARG characters forward, or send an EOF to process if at end of buffer." + (interactive "p") + (if (eobp) + (process-send-eof) + (delete-char arg))) + + + + + ;;; Support for source-file processing commands. + ;;;============================================================================ + ;;; Many command-interpreters (e.g., Lisp, Scheme, Soar) have + ;;; commands that process files of source text (e.g. loading or compiling + ;;; files). So the corresponding process-in-a-buffer modes have commands + ;;; for doing this (e.g., lisp-load-file). The functions below are useful + ;;; for defining these commands. + ;;; + ;;; Alas, these guys don't do exactly the right thing for Lisp, Scheme + ;;; and Soar, in that they don't know anything about file extensions. + ;;; So the compile/load interface gets the wrong default occasionally. + ;;; 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, ...). + + + ;;; COMINT-SOURCE-DEFAULT -- determines defaults for source-file processing + ;;; commands. + ;;; + ;;; COMINT-CHECK-SOURCE -- if FNAME is in a modified buffer, asks you if you + ;;; want to save the buffer before issuing any process requests to the command + ;;; interpreter. + ;;; + ;;; COMINT-GET-SOURCE -- used by the source-file processing commands to prompt + ;;; for the file to process. + + ;;; (COMINT-SOURCE-DEFAULT previous-dir/file source-modes) + ;;;============================================================================ + ;;; This function computes the defaults for the load-file and compile-file + ;;; commands for tea, soar, cmulisp, and cmuscheme modes. + ;;; + ;;; - PREVIOUS-DIR/FILE is a pair (directory . filename) from the last + ;;; source-file processing command. NIL if there hasn't been one yet. + ;;; - SOURCE-MODES is a list used to determine what buffers contain source + ;;; files: if the major mode of the buffer is in SOURCE-MODES, it's source. + ;;; Typically, (lisp-mode) or (scheme-mode). + ;;; + ;;; If the command is given while the cursor is inside a string, *and* + ;;; the string is an existing filename, *and* the filename is not a directory, + ;;; then the string is taken as default. This allows you to just position + ;;; your cursor over a string that's a filename and have it taken as default. + ;;; + ;;; If the command is given in a file buffer whose major mode is in + ;;; SOURCE-MODES, then the the filename is the default file, and the + ;;; file's directory is the default directory. + ;;; + ;;; If the buffer isn't a source file buffer (e.g., it's the process buffer), + ;;; then the default directory & file are what was used in the last source-file + ;;; processing command (i.e., PREVIOUS-DIR/FILE). If this is the first time + ;;; the command has been run (PREVIOUS-DIR/FILE is nil), the default directory + ;;; is the cwd, with no default file. (\"no default file\" = nil) + ;;; + ;;; SOURCE-REGEXP is typically going to be something like (tea-mode) + ;;; for T programs, (lisp-mode) for Lisp programs, (soar-mode lisp-mode) + ;;; for Soar programs, etc. + ;;; + ;;; The function returns a pair: (default-directory . default-file). + + (defun comint-source-default (previous-dir/file source-modes) + (cond ((and buffer-file-name (memq major-mode source-modes)) + (cons (file-name-directory buffer-file-name) + (file-name-nondirectory buffer-file-name))) + (previous-dir/file) + (t + (cons default-directory nil)))) + + + ;;; (COMINT-CHECK-SOURCE fname) + ;;;============================================================================ + ;;; Prior to loading or compiling (or otherwise processing) a file (in the CMU + ;;; process-in-a-buffer modes), this function can be called on the filename. + ;;; If the file is loaded into a buffer, and the buffer is modified, the user + ;;; is queried to see if he wants to save the buffer before proceeding with + ;;; the load or compile. + + (defun comint-check-source (fname) + (let ((buff (get-file-buffer fname))) + (if (and buff + (buffer-modified-p buff) + (y-or-n-p (format "Save buffer %s first? " + (buffer-name buff)))) + ;; save BUFF. + (let ((old-buffer (current-buffer))) + (set-buffer buff) + (save-buffer) + (set-buffer old-buffer))))) + + + ;;; (COMINT-GET-SOURCE prompt prev-dir/file source-modes mustmatch-p) + ;;;============================================================================ + ;;; COMINT-GET-SOURCE is used to prompt for filenames in command-interpreter + ;;; commands that process source files (like loading or compiling a file). + ;;; It prompts for the filename, provides a default, if there is one, + ;;; and returns the result filename. + ;;; + ;;; See COMINT-SOURCE-DEFAULT for more on determining defaults. + ;;; + ;;; PROMPT is the prompt string. PREV-DIR/FILE is the (directory . file) pair + ;;; from the last source processing command. SOURCE-MODES is a list of major + ;;; modes used to determine what file buffers contain source files. (These + ;;; two arguments are used for determining defaults). If MUSTMATCH-P is true, + ;;; then the filename reader will only accept a file that exists. + ;;; + ;;; A typical use: + ;;; (interactive (comint-get-source "Compile file: " prev-lisp-dir/file + ;;; '(lisp-mode) t)) + + ;;; This is pretty stupid about strings. It decides we're in a string + ;;; if there's a quote on both sides of point on the current line. + (defun comint-extract-string () + "Returns string around point that starts the current line or nil." + (save-excursion + (let* ((point (point)) + (bol (progn (beginning-of-line) (point))) + (eol (progn (end-of-line) (point))) + (start (progn (goto-char point) + (and (search-backward "\"" bol t) + (1+ (point))))) + (end (progn (goto-char point) + (and (search-forward "\"" eol t) + (1- (point)))))) + (and start end + (buffer-substring start end))))) + + (defun comint-get-source (prompt prev-dir/file source-modes mustmatch-p) + (let* ((def (comint-source-default prev-dir/file source-modes)) + (stringfile (comint-extract-string)) + (sfile-p (and stringfile + (file-exists-p stringfile) + (not (file-directory-p stringfile)))) + (defdir (if sfile-p (file-name-directory stringfile) + (car def))) + (deffile (if sfile-p (file-name-nondirectory stringfile) + (cdr def))) + (ans (read-file-name (if deffile (format "%s(default %s) " + prompt deffile) + prompt) + defdir + (concat defdir deffile) + mustmatch-p))) + (list (expand-file-name (substitute-in-file-name ans))))) + + ;;; I am somewhat divided on this string-default feature. It seems + ;;; to violate the principle-of-least-astonishment, in that it makes + ;;; the default harder to predict, so you actually have to look and see + ;;; what the default really is before choosing it. This can trip you up. + ;;; On the other hand, it can be useful, I guess. I would appreciate feedback + ;;; on this. + ;;; -Olin + + + ;;; Simple process query facility. + ;;; =========================================================================== + ;;; This function is for commands that want to send a query to the process + ;;; and show the response to the user. For example, a command to get the + ;;; arglist for a Common Lisp function might send a "(arglist 'foo)" query + ;;; to an inferior Common Lisp process. + ;;; + ;;; This simple facility just sends strings to the inferior process and pops + ;;; up a window for the process buffer so you can see what the process + ;;; responds with. We don't do anything fancy like try to intercept what the + ;;; process responds with and put it in a pop-up window or on the message + ;;; line. We just display the buffer. Low tech. Simple. Works good. + + ;;; Send to the inferior process PROC the string STR. Pop-up but do not select + ;;; a window for the inferior process so that its response can be seen. + (defun comint-proc-query (proc str) + (let* ((proc-buf (process-buffer proc)) + (proc-mark (process-mark proc))) + (display-buffer proc-buf) + (set-buffer proc-buf) ; but it's not the selected *window* + (let ((proc-win (get-buffer-window proc-buf)) + (proc-pt (marker-position proc-mark))) + (comint-send-string proc str) ; send the query + (accept-process-output proc) ; wait for some output + ;; Try to position the proc window so you can see the answer. + ;; This is bogus code. If you delete the (sit-for 0), it breaks. + ;; I don't know why. Wizards invited to improve it. + (if (not (pos-visible-in-window-p proc-pt proc-win)) + (let ((opoint (window-point proc-win))) + (set-window-point proc-win proc-mark) (sit-for 0) + (if (not (pos-visible-in-window-p opoint proc-win)) + (push-mark opoint) + (set-window-point proc-win opoint))))))) + + + ;;; Filename completion in a buffer + ;;; =========================================================================== + ;;; Useful completion functions, courtesy of the Ergo group. + ;;; M- will complete the filename at the cursor as much as possible + ;;; M-? will display a list of completions in the help buffer. + + ;;; Three commands: + ;;; comint-dynamic-complete Complete filename at point. + ;;; comint-dynamic-list-completions List completions in help buffer. + ;;; comint-replace-by-expanded-filename Expand and complete filename at point; + ;;; replace with expanded/completed name. + + ;;; These are not installed in the comint-mode keymap. But they are + ;;; available for people who want them. Shell-mode installs them: + ;;; (define-key cmushell-mode-map "\M-\t" 'comint-dynamic-complete) + ;;; (define-key cmushell-mode-map "\M-?" 'comint-dynamic-list-completions))) + ;;; + ;;; Commands like this are fine things to put in load hooks if you + ;;; want them present in specific modes. Example: + ;;; (setq cmushell-load-hook + ;;; '((lambda () (define-key lisp-mode-map "\M-\t" + ;;; 'comint-replace-by-expanded-filename)))) + ;;; + + + (defun comint-match-partial-pathname () + "Returns the string of an existing filename or causes an error." + (if (save-excursion (backward-char 1) (looking-at "\\s ")) "" + (save-excursion + (re-search-backward "[^~/A-Za-z0-9---_.$#,]+") + (re-search-forward "[~/A-Za-z0-9---_.$#,]+") + (substitute-in-file-name + (buffer-substring (match-beginning 0) (match-end 0)))))) + + + (defun comint-replace-by-expanded-filename () + "Replace the filename at point with an expanded, canonicalised, and + completed replacement. + \"Expanded\" means environment variables (e.g., $HOME) and ~'s are + replaced with the corresponding directories. \"Canonicalised\" means .. + and \. are removed, and the filename is made absolute instead of relative. + See functions expand-file-name and substitute-in-file-name. See also + comint-dynamic-complete." + (interactive) + (let* ((pathname (comint-match-partial-pathname)) + (pathdir (file-name-directory pathname)) + (pathnondir (file-name-nondirectory pathname)) + (completion (file-name-completion pathnondir + (or pathdir default-directory)))) + (cond ((null completion) + (message "No completions of %s." pathname) + (ding)) + ((eql completion t) + (message "Unique completion.")) + (t ; this means a string was returned. + (delete-region (match-beginning 0) (match-end 0)) + (insert (expand-file-name (concat pathdir completion))))))) + + + (defun comint-dynamic-complete () + "Dynamically complete the filename at point. + This function is similar to comint-replace-by-expanded-filename, except + that it won't change parts of the filename already entered in the buffer; + it just adds completion characters to the end of the filename." + (interactive) + (let* ((pathname (comint-match-partial-pathname)) + (pathdir (file-name-directory pathname)) + (pathnondir (file-name-nondirectory pathname)) + (completion (file-name-completion pathnondir + (or pathdir default-directory)))) + (cond ((null completion) + (message "No completions of %s." pathname) + (ding)) + ((eql completion t) + (message "Unique completion.")) + (t ; this means a string was returned. + (goto-char (match-end 0)) + (insert (substring completion (length pathnondir))))))) + + (defun comint-dynamic-list-completions () + "List in help buffer all possible completions of the filename at point." + (interactive) + (let* ((pathname (comint-match-partial-pathname)) + (pathdir (file-name-directory pathname)) + (pathnondir (file-name-nondirectory pathname)) + (completions + (file-name-all-completions pathnondir + (or pathdir default-directory)))) + (cond ((null completions) + (message "No completions of %s." pathname) + (ding)) + (t + (let ((conf (current-window-configuration))) + (with-output-to-temp-buffer "*Help*" + (display-completion-list completions)) + (sit-for 0) + (message "Hit space to flush.") + (let ((ch (read-char))) + (if (= ch ?\ ) + (set-window-configuration conf) + (setq unread-command-char ch)))))))) + + ; Ergo bindings + ; (global-set-key "\M-\t" 'comint-replace-by-expanded-filename) + ; (global-set-key "\M-?" 'comint-dynamic-list-completions) + ; (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete) + + ;;; Converting process modes to use comint mode + ;;; =========================================================================== + ;;; Several gnu packages (tex-mode, background, dbx, gdb, kermit, prolog, + ;;; telnet are some) use the shell package as clients. Most of them would + ;;; be better off using the comint package, but they predate it. + ;;; + ;;; Altering these packages to use comint mode should greatly + ;;; improve their functionality, and is fairly easy. + ;;; + ;;; Renaming variables + ;;; Most of the work is renaming variables and functions. These are the common + ;;; ones: + ;;; Local variables: + ;;; last-input-end comint-last-input-end + ;;; last-input-start + ;;; shell-prompt-pattern comint-prompt-regexp + ;;; shell-set-directory-error-hook + ;;; Miscellaneous: + ;;; shell-set-directory + ;;; shell-mode-map comint-mode-map + ;;; Commands: + ;;; shell-send-input comint-send-input + ;;; shell-send-eof comint-delchar-or-maybe-eof + ;;; kill-shell-input comint-kill-input + ;;; interrupt-shell-subjob comint-interrupt-subjob + ;;; stop-shell-subjob comint-stop-subjob + ;;; quit-shell-subjob comint-quit-subjob + ;;; kill-shell-subjob comint-kill-subjob + ;;; kill-output-from-shell comint-kill-output + ;;; show-output-from-shell comint-show-output + ;;; copy-last-shell-input Use comint-previous-input/comint-next-input + ;;; + ;;; LAST-INPUT-START is no longer necessary because inputs are stored on the + ;;; input history ring. SHELL-SET-DIRECTORY is gone, its functionality taken + ;;; over by SHELL-DIRECTORY-TRACKER, the shell mode's comint-input-sentinel. + ;;; Comint mode does not provide functionality equivalent to + ;;; shell-set-directory-error-hook; it is gone. + ;;; + ;;; If you are implementing some process-in-a-buffer mode, called foo-mode, do + ;;; *not* create the comint-mode local variables in your foo-mode function. + ;;; This is not modular. Instead, call comint-mode, and let *it* create the + ;;; necessary comint-specific local variables. Then create the + ;;; foo-mode-specific local variables in foo-mode. Set the buffer's keymap to + ;;; be foo-mode-map, and its mode to be foo-mode. Set the comint-mode hooks + ;;; (comint-prompt-regexp, comint-input-filter, comint-input-sentinel, + ;;; comint-get-old-input) that need to be different from the defaults. Call + ;;; foo-mode-hook, and you're done. Don't run the comint-mode hook yourself; + ;;; comint-mode will take care of it. The following example, from cmushell.el, + ;;; is typical: + ;;; + ;;; (defun shell-mode () + ;;; (interactive) + ;;; (comint-mode) + ;;; (setq comint-prompt-regexp shell-prompt-pattern) + ;;; (setq major-mode 'shell-mode) + ;;; (setq mode-name "Shell") + ;;; (cond ((not shell-mode-map) + ;;; (setq shell-mode-map (full-copy-sparse-keymap comint-mode-map)) + ;;; (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete) + ;;; (define-key shell-mode-map "\M-?" + ;;; 'comint-dynamic-list-completions))) + ;;; (use-local-map shell-mode-map) + ;;; (make-local-variable 'shell-directory-stack) + ;;; (setq shell-directory-stack nil) + ;;; (setq comint-input-sentinel 'shell-directory-tracker) + ;;; (run-hooks 'shell-mode-hook)) + ;;; + ;;; + ;;; Note that make-comint is different from make-shell in that it + ;;; doesn't have a default program argument. If you give make-shell + ;;; a program name of NIL, it cleverly chooses one of explicit-shell-name, + ;;; $ESHELL, $SHELL, or /bin/sh. If you give make-comint a program argument + ;;; of NIL, it barfs. Adjust your code accordingly... + ;;; + + ;;; Do the user's customisation... + + (defvar comint-load-hook nil + "This hook is run when comint is loaded in. + This is a good place to put keybindings.") + + (run-hooks 'comint-load-hook) + + ;;; Change log: + ;;; 9/12/89 + ;;; - Souped up the filename expansion procedures. + ;;; Doc strings are much clearer and more detailed. + ;;; Fixed a bug where doing a filename completion when the point + ;;; was in the middle of the filename instead of at the end would lose. + ;;; + ;;; 2/17/90 + ;;; - Souped up the command history stuff so that text inserted + ;;; by comint-previous-input-matching is removed by following + ;;; command history recalls. comint-next/previous-input-matching + ;;; is now much more smoothly integrated w/the command history stuff. + ;;; - Added comint-eol-on-send flag and comint-input-sender hook. + ;;; Comint-input-sender based on code contributed by Jeff Peck + ;;; (peck@sun.com). + ;;; + ;;; 3/13/90 ccm@cmu.cs.edu + ;;; - Added comint-previous-similar-input for looking up similar inputs. + ;;; - Added comint-send-and-get-output to allow snarfing input from + ;;; buffer. + ;;; - Added the ability to pick up a source file by positioning over + ;;; a string in comint-get-source. + ;;; - Added add-hook to make it a little easier for the user to use + ;;; multiple hooks. + ;;; + ;;; 5/22/90 shivers + ;;; - Moved Chris' multiplexed ipc stuff to comint-ipc.el. + ;;; - Altered Chris' comint-get-source string feature. The string + ;;; is only offered as a default if it names an existing file. + ;;; - Changed comint-exec to directly crank up the process, instead + ;;; of calling the env program. This made background.el happy. + ;;; - Added new buffer-local var comint-ptyp. The problem is that + ;;; the signalling functions don't work as advertised. If you are + ;;; communicating via pipes, the CURRENT-GROUP arg is supposed to + ;;; be ignored, but, unfortunately it seems to be the case that you + ;;; must pass a NIL for this arg in the pipe case. COMINT-PTYP + ;;; is a flag that tells whether the process is communicating + ;;; via pipes or a pty. The comint signalling functions use it + ;;; to determine the necessary CURRENT-GROUP arg value. The bug + ;;; has been reported to the Gnu folks. + ;;; - comint-dynamic-complete flushes the help window if you hit space + ;;; after you execute it. + ;;; - Added functions comint-send-string, comint-send-region and var + ;;; comint-input-chunk-size. comint-send-string tries to prevent processes + ;;; from hanging when you send them long strings by breaking them into + ;;; chunks and allowing process output between chunks. I got the idea from + ;;; Eero Simoncelli's Common Lisp package. Note that using + ;;; comint-send-string means that the process buffer's contents can change + ;;; during a call! If you depend on process output only happening between + ;;; toplevel commands, this could be a problem. In such a case, use + ;;; process-send-string instead. If this is a problem for people, I'd like + ;;; to hear about it. + ;;; - Added comint-proc-query as a simple mechanism for commands that + ;;; want to query an inferior process and display its response. For a + ;;; typical use, see lisp-show-arglist in cmulisp.el. + ;;; - Added constant comint-version, which is now "2.01". + ;;; + ;;; 6/14/90 shivers + ;;; - Had comint-update-env defined twice. Removed extra copy. Also + ;;; renamed mem to be comint-mem, for modularity. The duplication + ;;; was reported by Michael Meissner. + ;;; 6/16/90 shivers + ;;; - Emacs has two different mechanisms for maintaining the process + ;;; environment, determined at compile time by the MAINTAIN-ENVIRONMENT + ;;; #define. One uses the process-environment global variable, and + ;;; one uses a getenv/setenv interface. comint-exec assumed the + ;;; process-environment interface; it has been generalised (with + ;;; comint-exec-1) to handle both cases. Pretty bogus. We could, + ;;; of course, skip all this and just use the etc/env program to + ;;; handle the environment tweaking, but that obscures process + ;;; queries that other modules (like background.el) depend on. etc/env + ;;; is also fairly bogus. This bug, and some of the fix code was + ;;; reported by Dan Pierson. + ;;; + ;;; 9/5/90 shivers + ;;; - Changed make-variable-buffer-local's to make-local-variable's. + ;;; This leaves non-comint-mode buffers alone. Stephane Payrard + ;;; reported the sloppy useage. + ;;; - You can now go from comint-previous-similar-input to + ;;; comint-previous-input with no problem. *** /dev/null Thu Oct 31 13:46:13 1991 --- scrt/apollo.asm Wed Oct 23 16:33:08 1991 *************** *** 0 **** --- 1,229 ---- + * apollo.asm - Apollo specific module for DEC's Scheme->C + * + * This file implements the assembly language part of the Apollo port, + * specifically for the DN3000 and DN4000 series, that is, depending on + * the M68020 CPU and M68881 FPP. + * + * Included are all the necessary math routines to catch integer overflow. + * + * This file is written for PIC (Position Independent Code), to build + * a shared library. + * + * Ray Lischner (uunet!mntgfx!lisch) + * 26 April 1990 + + module sc_apollo + cpu 68020,68881 + sri 68020 + + entry sc_setregs + entry sc_regs + entry sc_iplus + entry sc_idifference + entry sc_inegate + entry sc_itimes + + data + + * set up jump tables for calling PIC routines + data_start equ * + + sc_iplus lea data_start,a0 + jmp.l sc$iplus + sc_idifference lea data_start,a0 + jmp.l sc$idifference + sc_inegate lea data_start,a0 + jmp.l sc$inegate + sc_itimes lea data_start,a0 + jmp.l sc$itimes + + * set up transfer address for external PIC routines + extern sc_makefloat64 + sc$makefloat64 ac sc_makefloat64 + + text + + *********************************************************************** + * void sc_setregs(int* a6, int* a7) + * Apollo's longjmp() checks to see if the jump is backwards in the stack. + * If not, it assumes that something is wrong and ungracefully terminates + * the program. Since we don't want this to happen, we need to fake + * out Domain/OS. This is done by setting the stack pointer (a7) and + * frame pointer (a6) to the destination frame, thus circumventing + * longjmp's checks. + * + * To accomplish this takes some clever tricks. First, we need to know + * how the stack is layed out: + * + * (lower addresses) + * +----------------------------+ + * A7 | local storage ... | + * +----------------------------+ + * A6 | link to previous frame | + * +----------------------------+ + * | return address | + * +----------------------------+ + * | arguments pushed by caller | + * +----------------------------+ + * (higher addresses) + * Note that we are ignoring floating point control blocks. + * + * The caller pushes the desired values for A7 and A6. On entry to sc_setregs(), + * A6 points to the caller's frame, and A7 points to the return address. + * We can retrieve the caller's arguments by dereferencing a7: the second + * argument is in 8(a7), and the first is in 4(a7). We can just copy + * them into the registers we want, but first we need to save the return + * address before we lose the pointer to it. It is saved in A0, at the + * same time we load A6 and A7. Clever, isn't it? After getting the new + * register values, we know that the caller will try to pop the + * arguments off the stack by adding 8 to A7. We circumvent this by + * subtracting 8 now. + + sc_setregs procedure "sc_setregs",nocode + movem.l (a7),a0/a6-a7 + subq.l #8,a7 + jmp (a0) + + *********************************************************************** + * void sc_regs(int regs[12]) + * sc_regs returns the values of a1-a4, d0-d7 in the caller supplied buffer. + * These are the "callee" save registers that need to be examined during + * garbage collection. + + sc_regs procedure "sc_regs",#-4 + move.l 8(a6),a0 * a0 := ®s[0] + movem.l d0-d7/a1-a4,(a0) * save the interesting registers + return sc_regs + + *********************************************************************** + * The following routines are for doing arithmetic on tagged numbers. + * The input arguments are tagged integers, that is, integers shifted + * left by two bits. (Except for sc_itimes, where only the second + * argument, b, is shifted.) This makes it easier to check for overflow, + * but we must unshift the values before calling sc_makefloat64(). + * + * When the result of any operation overflows, the operands are converted + * to floating point, and the operation is repeated. The floating point + * result is then passed to sc_makefloat64() to produce a float object + * to return. + + * int sc_iplus(int a, int b) + * returns the integer sum, a + b, where a and b are the two + * integer arguments, unless integer overflow occurs, then returns + * (unsigned int) sc_makefloat64( (double)a + (double)b ) instead. + + sc$iplus procedure "sc_iplus",#0,a5 + move.l a0,a5 + * add the arguments + move.l 8(a6),d0 + move.l 12(a6),d1 + add.l d1,d0 + * if the operation overflows, we know to use floating point + bvc 1$ + + * otherwise, convert to floating point and add + move.l 8(a6),d0 + asr.l #2,d0 + fmove.l d0,fp0 + * note that d1 still contains "b" + asr.l #2,d1 + fmove.l d1,fp1 + fadd fp1,fp0 + * pass the floating point sum to sc_makefloat64 + fmove.d fp0,-(sp) + move.l sc$makefloat64,a0 + jsr (a0) + addq.l #8,sp + + 1$ return sc$iplus + + + * int sc_idifference(int a, int b) + * returns integer difference, a - b, where a and b are the two + * integer arguments, unless integer overflow occurs, then returns + * (unsigned int) sc_makefloat64( (double)a - (double)b ) instead. + * + + sc$idifference procedure "sc_idifference",#0,a5 + move.l a0,a5 + * subtract the arguments + move.l 8(a6),d0 + move.l 12(a6),d1 + sub.l d1,d0 + * if the operation overflows, we know to use floating point + bvc 1$ + + * otherwise, convert to floating point and subtract + move.l 8(a6),d0 + asr.l #2,d0 + fmove.l d0,fp0 + * note that d1 still contains "b" + asr.l #2,d1 + fmove.l d1,fp1 + fsub fp1,fp0 + * pass the floating point sum to sc_makefloat64 + fmove.d fp0,-(sp) + move.l sc$makefloat64,a0 + jsr (a0) + addq.l #8,sp + + 1$ return sc$idifference + + * int sc_inegate(int a) + * returns integer negation, -a, where a is the integer + * argument, unless integer overflow occurs, then returns + * (unsigned int) sc_makefloat64( -(double)a) instead. + * + + sc$inegate procedure "sc_inegate",#0,a5 + move.l a0,a5 + * negate the argument + move.l 8(a6),d0 + move.l d0,d1 + neg.l d0 + * if the operation overflows, we know to use floating point + bvc 1$ + + * otherwise, convert to floating point and negate + asr.l #2,d1 + fmove.l d1,fp1 + fneg fp1,fp0 + * pass the floating point sum to sc_makefloat64 + fmove.d fp0,-(sp) + move.l sc$makefloat64,a0 + jsr (a0) + addq.l #8,sp + + 1$ return sc$inegate + + * sc_itimes(int a, int b) + * returns integer procuct, a * b, where a and b are the two + * integer arguments, unless integer overflow occurs, then returns + * (unsigned int) sc_makefloat64( (double)a * (double)b ) instead. + * Unlike the previous arithmetic functions, only "b" has been shifted. + + sc$itimes procedure "sc_itimes",#0,a5 + move.l a0,a5 + * multiply the arguments + move.l 8(a6),d0 + move.l 12(a6),d1 + muls.l d1,d0 + + * if the operation overflows, we know to use floating point + bvc 1$ + + * otherwise, convert to floating point and multiply + fmove.l 8(a6),fp0 + * note that d1 still contains "b" + asr.l #2,d1 + fmove.l d1,fp1 + fmul fp1,fp0 + * pass the floating point sum to sc_makefloat64 + fmove.d fp0,-(sp) + move.l sc$makefloat64,a0 + jsr (a0) + addq.l #8,sp + + 1$ return sc$itimes + + end *** /dev/null Thu Oct 31 13:46:13 1991 --- scrt/apollo.o.uu Wed Oct 23 16:33:10 1991 *************** *** 0 **** --- 1,69 ---- + begin 444 apollo.o + M 9< "28WDLH DT '0 L@ X 0 ! #) "P @ + M 0 (?@ "YT97AT "!J @:@ $$ !J + M @ " N=6YW:6YD @JP (*L > JP B* + M ' @+F1A=&$ 0 $ "P + M( @"YB;&]C:W, $ + ! "P '@ #) "- 0 # N + M;&EN97, ! @P 0(, D@ !00 P +G-Y;6)O + M;', 0*> $"G@ I8 66 , "YR=V1I $% + M- !!30 X (+ "/@ 8 ! N;6ER + M &@ "&0 ( +G-R:0 P + M A^ " $S7P0!1CT[03E;__"!N A(T![_3EY.=4Y6 + M O#2I(("X ""(N S0@6@ "(@+@ (Y(#R $ Y('R 4" \@ $(O(G= @ + M;0 H3I!0CRIN__Q.7DYU3E8 "\-*D@@+@ ((BX #)"!: (B N CD@/( + M0 #D@?(!0(#R 0H\B=T "!M "A.D%"/*F[__$Y>3G5.5@ +PTJ2" N @B + M $2 : &.2!\@% @/( !!KR)W0 (&T *$Z04(\J;O_\3EY.=4Y6 O#2I( + M("X ""(N Q, 0@ : 'O(N0 ".2!\@% @/( !"/R)W0 (&T *$Z04(\J + M;O_\3EY.=0 "!J ! @0 !X @:@ @# @ + M @; ! ! /____P (' ^ 2 #____\ "!_@ /@$@ + M _____ @CP #(!( /____P ()N \ 2 #____\ 0 ! @ + M 4 !P #H : +@ > " $ $"# ! IX (&H $ , %* + M"O-, !*@0 5P @ / 0 "P ! 0 + M $ (" * $^ ( $ ( , $ 0! " + M @ "@ !(0 " * ! $ # " ! ' 0 @( H + M 0$ @ % 0 #X P !@ 0 "H$ (" * + M #B ( !X $ ^ , !6 $ !%! " @ "@ R0 " + M H ! ,@ # E ! 8 0 @( *P @ ,@ + M 0 #P P ,8 0 '@; (@O+VIE;&QI;W1T+VQO8V%L7W5S97(O + M9VYU+G-R8RYP ! "YL + M:6YE

6UB;VQS $" + MG@ & # 0 I8 "YR=V1I $%- ' # 0 + M #@ !@ "YM:7( ( # 0 !H + M "YScontinuation.address ); #endif + #ifdef APOLLO + sc_setregs( (T_U(callcccp))->continuation.savedstate[3], + (T_U(callcccp))->continuation.savedstate[2]); + #endif longjmp( (T_U(callcccp))->continuation.savedstate, 1 ); } + TSCP sc_ntinuation_1af38b9f_v; *** 1.1 1991/10/23 18:48:22 --- scrt/callcc.h 1991/10/31 19:33:33 *************** *** 39,46 **** * SOFTWARE. */ ! /* This module implements CALL-WITH-CURRENT-CONTINUATION. SC_CLINK is a ! pointer to the current "inner most" continuation on the stack. */ extern TSCP sc_clink; --- 39,47 ---- * SOFTWARE. */ ! /* ! This module implements CALL-WITH-CURRENT-CONTINUATION. SC_CLINK is ! a pointer to the current "inner most" continuation on the stack. */ extern TSCP sc_clink; *** 1.1 1991/10/23 18:48:23 --- scrt/cio.c 1991/10/31 17:08:20 *************** *** 41,50 **** --- 41,71 ---- /* This module supplies functions to access C Library I/O macros. */ + #include #include #include #include "objects.h" + #include "cio.h" + + /* This really does not need to be dependant on ISC386IX, just the lack of */ + /* a rename function. This is just a dirty hack. */ + #ifdef ISC386IX + #include + #include + #include + int rename(old, new) char *old, *new; + { + if (link(old, new) < 0) + if (errno == EEXIST && unlink(new) == 0 && link(old, new) < 0) + return 0; + else + return -1; + else if (unlink(old) == 0) + return 0; + return -1; + } + #endif int sc_libc_eof = EOF; *************** *** 84,100 **** --- 105,132 ---- input characters ready, and 0 when none are available. */ + /* The changes here are probably generic Sys5 changes, but what the heck */ int sc_inputchars( stream ) FILE *stream; { int readfds, nfound; + #ifndef ISC386IX struct timeval timeout; + #else + struct pollfd pollfd; + #endif if (((stream)->_cnt) <= 0) { + #ifndef ISC386IX readfds = 1<<(fileno( stream )); timeout.tv_sec = 0; timeout.tv_usec = 0; nfound = select( fileno( stream )+1, &readfds, 0, 0, &timeout ); + #else + pollfd.fd = fileno( stream ); + pollfd.events = POLLIN; + nfound = poll(&pollfd, 1, 0); + #endif if (nfound == 0) return( 0 ); } return( 1 ); *** 1.1 1991/10/23 18:48:27 --- scrt/heap.c 1991/10/31 17:13:10 *************** *** 56,61 **** --- 56,67 ---- #ifdef VAX extern sc_r2tor11(); #endif + #ifdef APOLLO + extern sc_regs(); + #endif + #ifdef SUN3 + extern sc_a2to5d2to7(); + #endif /* Forward declarations */ *************** *** 63,68 **** --- 69,76 ---- extern SCP move_object(); + static move_continuation_ptr(); + /* Allocate storage which is defined in "heap.h" */ int *sc_pagegeneration, /* page generation table */ *************** *** 98,106 **** --- 106,116 ---- int sc_gcinfo; /* controls logging */ + #ifndef SYSV static struct rusage gcru, /* resource consumption during collection */ startru, stopru; + #endif static int sc_newlist; /* list of newly allocated pages */ *************** *** 141,146 **** --- 151,157 ---- if (tail == page) tail = 0; \ } + #ifndef SYSV /* The following function converts a rusage structure into an 18 word Scheme vector composed of the same items. */ *************** *** 271,276 **** --- 282,292 ---- return( rusagevector( &gcru ) ); } + #else + #define getrusage(x,y) /* no operation */ + #define updategcru() /* no operation */ + #endif /* SYSV-BSD dependency */ + /* Errors detected during garbage collection are logged by the following procedure. If any errors occur, the program will abort after logging them. More than 30 errors will result in the program being aborted at *************** *** 282,287 **** --- 298,304 ---- static int pointer_errors = 0; static void pointererror( msg, pp ) + char *msg; SCP pp; { fprintf( stderr, "***** COLLECT pointer error in %x, ", *************** *** 378,384 **** pp = STACKPTR; while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); } ! #endif TITAN #ifdef VAX /* The following code is used to read the stack pointer. The register --- 395,401 ---- pp = STACKPTR; while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); } ! #endif /* TITAN */ #ifdef VAX /* The following code is used to read the stack pointer. The register *************** *** 404,410 **** pp = STACKPTR; while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); } ! #endif VAX #ifdef MIPS /* The following code is used to read the stack pointer. The register --- 421,427 ---- pp = STACKPTR; while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); } ! #endif /* VAX */ #ifdef MIPS /* The following code is used to read the stack pointer. The register *************** *** 430,436 **** pp = STACKPTR; while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); } ! #endif MIPS /* The size of an extended object in words is returned by the following --- 447,563 ---- pp = STACKPTR; while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); } ! #endif /* MIPS */ ! ! #ifdef APOLLO ! /* The following code is used to read the stack pointer. The register ! number is passed in to force an argument to be on the stack, which in ! turn can be used to find the address of the top of stack. ! */ ! ! int *sc_processor_register( reg ) ! int reg; ! { ! return( ® ); ! } ! ! /* All processor registers that might contain pointers are traced by the ! following procedure. ! */ ! ! static trace_stack_and_registers() ! { ! int i, a1toa4_d0tod7[12], *pp; ! ! sc_regs( a1toa4_d0tod7 ); ! pp = STACKPTR; ! while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); ! } ! #endif /* APOLLO */ ! ! #ifdef PRISM ! /* All processor registers that might contain pointers are traced by the ! following procedure. ! */ ! ! static trace_stack_and_registers() ! { ! int i, regs[12], *pp; ! ! sc_regs( regs ); ! pp = STACKPTR; ! while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); ! } ! #endif /* PRISM */ ! ! #ifdef SPARC ! /* All processor registers which might contain pointers are traced by the ! following procedure. ! */ ! ! static trace_stack_and_registers() ! { ! int i, *pp; ! sc_jmp_buf tmp; ! ! pp = STACKPTR; ! while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); ! } ! #endif SPARC ! ! #ifdef SUN3 ! /* The following code is used to read the stack pointer. The register ! number is passed in to force an argument to be on the stack, which in ! turn can be used to find the address of the top of stack. ! */ ! ! int *sc_processor_register( reg ) ! int reg; ! { ! return( ®+1 ); ! } ! ! /* All processor registers which might contain pointers are traced by the ! following procedure. ! */ ! ! static trace_stack_and_registers() ! { ! int i, a2to5d2to7[10], *pp; ! ! sc_a2to5d2to7( a2to5d2to7 ); ! pp = STACKPTR; ! while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); ! } ! #endif SUN3 ! ! ! #ifdef I386 ! /* The following code is used to read the stack pointer. The register ! number is passed in to force an argument to be on the stack, which in ! turn can be used to find the address of the top of stack. ! */ ! ! int *sc_processor_register( reg ) ! int reg; ! { ! return( ® ); ! } ! ! /* All processor registers which might contain pointers are traced by the ! following procedure. ! */ ! ! static trace_stack_and_registers() ! { ! int i, *pp; ! sc_jmp_buf tmp; ! ! setjmp(tmp); ! pp = STACKPTR; ! while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); ! } ! #endif I386 /* The size of an extended object in words is returned by the following *************** *** 577,583 **** } words = extendedsize( pp ); length = words; ! newp = (int*)sc_allocateheap( extendedsize( pp ), pp->extendedobj.tag, 0 ); new = U_T( newp, EXTENDEDTAG ); oldp = (int*)pp; --- 704,710 ---- } words = extendedsize( pp ); length = words; ! newp = (int*)sc_allocateheap( length, pp->extendedobj.tag, 0 ); new = U_T( newp, EXTENDEDTAG ); oldp = (int*)pp; *************** *** 1300,1305 **** --- 1427,1433 ---- check_obarray(); } if (sc_gcinfo) { + #ifndef SYSV fprintf( stderr, "\n***** COLLECT %d%% allocated (%d%% waste, %d MB) -> \n", (wasallocated*100)/sc_heappages, *************** *** 1405,1410 **** --- 1533,1544 ---- " %d system ms %d page faults\n", stopru.ru_stime.tv_sec*1000+stopru.ru_stime.tv_usec/1000, stopru.ru_majflt ); + #else + fprintf( stderr, + " %d%% locked %d%% retained\n", + (sc_lockcnt*100)/sc_heappages, + (sc_generationpages*100)/sc_heappages); + #endif } if (sc_gcinfo == 2) { /* Perform additional consistency checks */ *************** *** 1634,1641 **** --- 1768,1779 ---- the Scheme object with that value. */ + #ifdef PRISM + TSCP sc_makefloat32( float value ) + #else TSCP sc_makefloat32( value ) float value; + #endif { SCP pp; *************** *** 1644,1650 **** pp = sc_extobjp; sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT32SIZE); sc_extobjwords = sc_extobjwords-FLOAT32SIZE; ! pp->unsi.gned = FLOAT32TAG; } else pp = sc_allocateheap( FLOAT32SIZE, FLOAT32TAG, 0 ); --- 1782,1789 ---- pp = sc_extobjp; sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT32SIZE); sc_extobjwords = sc_extobjwords-FLOAT32SIZE; ! pp->float32.tag = FLOAT32TAG; ! pp->float32.rest = 0; } else pp = sc_allocateheap( FLOAT32SIZE, FLOAT32TAG, 0 ); *************** *** 1656,1665 **** --- 1795,1814 ---- /* 64-bit floating point numbers are constructed by the following function. It is called with a 64-bit floating point value and it returns a pointer to the Scheme object with that value. + + On the Apollo Prism, it is vital that we use a function prototype, + so the compiler knows that the function's argument is being passed + in a register. Without the prototype, the argument is read from + the stack. See prism.asm for examples where it is simpler to pass + the argument in a register. Also see objects.h for the declaration. */ + #ifdef PRISM + TSCP sc_makefloat64( double value ) + #else TSCP sc_makefloat64( value ) double value; + #endif { SCP pp; *************** *** 1669,1675 **** pp = sc_extobjp; sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT64SIZE); sc_extobjwords = sc_extobjwords-FLOAT64SIZE; ! pp->unsi.gned = FLOAT64TAG; } else pp = sc_allocateheap( FLOAT64SIZE, FLOAT64TAG, 0 ); --- 1818,1825 ---- pp = sc_extobjp; sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT64SIZE); sc_extobjwords = sc_extobjwords-FLOAT64SIZE; ! pp->float64.tag = FLOAT64TAG; ! pp->float64.rest = 0; } else pp = sc_allocateheap( FLOAT64SIZE, FLOAT64TAG, 0 ); *** 1.1 1991/10/23 18:48:29 --- scrt/heap.h 1991/10/23 21:30:39 *************** *** 42,51 **** --- 42,74 ---- /* Import definitions */ #ifndef rusage + + #ifdef apollo + #include + #else + #ifdef SPARC + #include + #else + #ifdef SUN3 + #include + #else + #ifdef NeXT + #include + #else + #ifndef SYSV #include + #endif + #endif + #endif + #endif + #endif + + #ifndef SYSV #include #endif + #endif + /* This module implements the object storage storage system for SCHEME->C. Unlike most Lisp systems, it is not intended that SCHEME->C provide a *************** *** 333,338 **** --- 356,386 ---- #ifdef VAX #define STACKPTR sc_processor_register( 14 ) + #endif + + #ifdef APOLLO + #define STACKPTR sc_processor_register( 7 ) + #endif + + #ifdef PRISM + extern int* prism_stack_frame(void); + #define STACKPTR prism_stack_frame() + #endif + + #ifdef I386 + #define STACKPTR sc_processor_register( 4 ) + #endif + + #ifdef SPARC + #define STACKPTR sc_processor_register( 0 ) + #endif + + #ifdef SUN3 + #define STACKPTR sc_processor_register( 15 ) + #endif + + #ifdef NeXT + #define STACKPTR sc_processor_register( 15 ) #endif /* Some objects require cleanup actions when they are freed. For example, *** 1.1 1991/10/23 18:48:30 --- scrt/makefile-tail 1991/10/25 16:02:37 *************** *** 15,20 **** --- 15,22 ---- Chfiles = scinit.h apply.h callcc.h cio.h heap.h objects.h signal.h + objects.h = objects.h + Sruntime = scdebug.o sceval.o scexpand.o scexpanders1.o scexpanders2.o \ scqquote.o screp.o \ scrt1.o scrt2.o scrt3.o scrt4.o scrt5.o scrt6.o scrt7.o *************** *** 31,37 **** scqquote.sc screp.sc \ scrt1.sc scrt2.sc scrt3.sc scrt4.sc scrt5.sc scrt6.sc scrt7.sc ! Smisc = mips.s predef.sc repdef.sc sci.sc sci.c vax.s ${Sruntimec} sci.c: ${predef.sc} ${objects.h} --- 33,46 ---- scqquote.sc screp.sc \ scrt1.sc scrt2.sc scrt3.sc scrt4.sc scrt5.sc scrt6.sc scrt7.sc ! Smisc = mips.s predef.sc repdef.sc sci.sc sci.c vax.s \ ! sparc.s i386.s sun3.s sparc-pragma.h next.s \ ! apollo.asm apollo.o.uu prism.asm prism.o.uu ! ! all: libsc.a sci ${Plib} ! ! # $(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = ${sccomp}" \ ! # Xlibsc.a Xsci Xmv ${Plib} ${Sruntimec} sci.c: ${predef.sc} ${objects.h} *************** *** 46,53 **** .c.u: ${CC} -j -D${cpu} -I. $*.c .s.o: ! ${CC} -c $*.s sc-to-c: ${Sruntimec} --- 55,67 ---- .c.u: ${CC} -j -D${cpu} -I. $*.c + # Apollo assembler + .asm.o: + $(ASM) $* $(AFLAGS) + -mv $*.bin $*.o + .s.o: ! ${CC} -c ${SUN_ASFLAGS} $*.s sc-to-c: ${Sruntimec} *************** *** 55,69 **** s-to-o: ${Aruntime} ! Xlibsc.a: ${Sruntimec} ${Sruntime} ${Cruntime} ${Aruntime} ! rm -f Xlibsc.a ! ar q Xlibsc.a ${Cruntime} ${Sruntime} ${Aruntime} ! ranlib Xlibsc.a ! ! Xsci: ${Sruntimec} ${Sruntime} ${Cruntime} ${Aruntime} \ ! sci.c sci.o ! ${CC} -o Xsci ${CFLAGS} ${Sruntime} ${Cruntime} ${Aruntime} sci.o \ ! -lm Xmv: Xsci Xlibsc.a mv Xsci sci --- 69,82 ---- s-to-o: ${Aruntime} ! Xlibsc.a libsc.a: ${Sruntimec} ${Sruntime} ${Cruntime} ${Aruntime} ! rm -f $@ ! ar q $@ ${Cruntime} ${Sruntime} ${Aruntime} ! ranlib $@ ! ! Xsci sci: ${Sruntimec} ${Sruntime} ${Cruntime} ${Aruntime} sci.c sci.o ! ${CC} -o $@ ${CFLAGS} ${Sruntime} ${Cruntime} ${Aruntime} sci.o \ ! ${CLIBS} Xmv: Xsci Xlibsc.a mv Xsci sci *************** *** 70,76 **** mv Xlibsc.a libsc.a port: ! make "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo" \ Xlibsc.a Xsci Xmv ${Plib} libsc_p.a: libsc.a --- 83,89 ---- mv Xlibsc.a libsc.a port: ! $(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo sccomp" \ Xlibsc.a Xsci Xmv ${Plib} libsc_p.a: libsc.a *************** *** 77,83 **** mkdir saveobj mv ${Sruntime} ${Cruntime} ${Aruntime} saveobj rm -f libsc_p.a ! make "CC = ${CC}" "CFLAGS = ${CFLAGS} -pg" ${Sruntime} ${Cruntime} \ ${Aruntime} ar q libsc_p.a ${Cruntime} ${Sruntime} ${Aruntime} ranlib libsc_p.a --- 90,96 ---- mkdir saveobj mv ${Sruntime} ${Cruntime} ${Aruntime} saveobj rm -f libsc_p.a ! $(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS} -pg" ${Sruntime} ${Cruntime} \ ${Aruntime} ar q libsc_p.a ${Cruntime} ${Sruntime} ${Aruntime} ranlib libsc_p.a *************** *** 119,133 **** rm -f sci libsc.a libsc_p.a srcdist: ! rdist -c README *.c *.h *.s *.sc makefile-tail ${destdir} bindist: rdist -c README makefile makefile-tail predef.sc objects.h \ libsc.a ${Plib} sci ${destdir} - - all: - make "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = ${sccomp}" \ - Xlibsc.a Xsci Xmv ${Plib} srclinks: for x in ${Cruntimec} ${Chfiles} ${Sruntimec} ${Sruntimesc} ${Smisc}; \ --- 132,142 ---- rm -f sci libsc.a libsc_p.a srcdist: ! rdist -c README *.c *.h *.s *.sc *.asm makefile-tail ${destdir} bindist: rdist -c README makefile makefile-tail predef.sc objects.h \ libsc.a ${Plib} sci ${destdir} srclinks: for x in ${Cruntimec} ${Chfiles} ${Sruntimec} ${Sruntimesc} ${Smisc}; \ *** 1.1 1991/10/23 18:48:31 --- scrt/mips.s 1991/10/23 21:30:40 *************** *** 49,59 **** --- 49,63 ---- collection. */ + #ifdef sony_news + #include + #else #ifndef MIPSEL #include #else #include #endif + #endif /* sony_news */ .text .align 2 *** /dev/null Thu Oct 31 13:46:23 1991 --- scrt/next.s Wed Oct 23 16:33:11 1991 *************** *** 0 **** --- 1,69 ---- + | + | SCHEME->C + | + | NeXT assembly code. + | + + | + | Copyright 1989 Digital Equipment Corporation + | All Rights Reserved + | + | Permission to use, copy, and modify this software and its documentation is + | hereby granted only under the following terms and conditions. Both the + | above copyright notice and this permission notice must appear in all copies + | of the software, derivative works or modified versions, and any portions + | thereof, and both notices must appear in supporting documentation. + | + | Users of this software agree to the terms and conditions set forth herein, + | and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free + | right and license under any changes, enhancements or extensions made to the + | core functions of the software, including but not limited to those affording + | compatibility with other hardware or software environments, but excluding + | applications which incorporate this software. Users further agree to use + | their best efforts to return to Digital any such changes, enhancements or + | extensions that they make and inform Digital of noteworthy uses of this + | software. Correspondence should be provided to Digital at: + | + | Director of Licensing + | Western Research Laboratory + | Digital Equipment Corporation + | 100 Hamilton Avenue + | Palo Alto, California 94301 + | + | This software may be distributed (but not offered for sale or transferred + | for compensation) to third parties, provided such third parties agree to + | abide by the terms and conditions of this notice. + | + | THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL + | WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF + | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT + | CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL + | DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR + | PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS + | ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS + | SOFTWARE. + | + + | + | sc_a2to5d2to7 + | + | sc_a2to5d2to7( a ) + | will return the contents of A2, ..., A5, D2, ..., D7 starting at address 'a'. + | + | + .text + .globl _sc_a2to5d2to7 + .even + _sc_a2to5d2to7: + movl sp@(4),a0 + movl a2,a0@(0) + movl a3,a0@(4) + movl a4,a0@(8) + movl a5,a0@(12) + movl d2,a0@(16) + movl d3,a0@(20) + movl d4,a0@(24) + movl d5,a0@(28) + movl d6,a0@(32) + movl d7,a0@(36) + rts *** 1.1 1991/10/23 18:48:33 --- scrt/objects.c 1991/10/31 17:19:54 *************** *** 518,524 **** break; case EXTENDEDTAG: if (TX_U( p )->extendedobj.tag == FLOATTAG) ! return( (int)( TX_U( p )->FLOATUTYPE.value ) ); break; } sc_error( "TSCP_INT", "Argument cannot be converted to C int", 0 ); --- 518,524 ---- break; case EXTENDEDTAG: if (TX_U( p )->extendedobj.tag == FLOATTAG) ! return ROUND( FLOAT_VALUE( p ) ); break; } sc_error( "TSCP_INT", "Argument cannot be converted to C int", 0 ); *************** *** 542,550 **** if (TX_U( p )->extendedobj.tag == FLOATTAG) { v = TX_U( p )->FLOATUTYPE.value; if (v <= (double)(0x7fffffff)) ! return( (unsigned)( v ) ); else ! return( (unsigned)( v-((double)(0x40000000))*2.0 ) | 0x80000000 ); } break; --- 542,550 ---- if (TX_U( p )->extendedobj.tag == FLOATTAG) { v = TX_U( p )->FLOATUTYPE.value; if (v <= (double)(0x7fffffff)) ! return( (unsigned)ROUND( v ) ); else ! return( (unsigned)ROUND( v-((double)(0x40000000))*2.0 ) | 0x80000000 ); } break; *************** *** 579,587 **** case FLOATTAG: v = TX_U( p )->FLOATUTYPE.value; if (v <= (double)(0x7fffffff)) ! return( (unsigned)( v ) ); else ! return( (unsigned)( v-((double)(0x40000000))*2.0 ) | 0x80000000 ); break; } --- 579,587 ---- case FLOATTAG: v = TX_U( p )->FLOATUTYPE.value; if (v <= (double)(0x7fffffff)) ! return( (unsigned int)( v ) ); else ! return( (unsigned int)( v-((double)(0x40000000))*2.0 ) | 0x80000000 ); break; } *** 1.1 1991/10/23 18:48:34 --- scrt/objects.h 1991/10/31 17:23:32 *************** *** 43,52 **** */ /* Default the value of CPUTYPE if not currently defined. */ - #ifndef MIPS #ifndef TITAN #ifndef VAX #ifdef mips #define MIPS 1 #endif --- 43,57 ---- */ /* Default the value of CPUTYPE if not currently defined. */ #ifndef MIPS #ifndef TITAN #ifndef VAX + #ifndef SPARC + #ifndef SUN3 + #ifndef I386 + #ifndef APOLLO + #ifndef PRISM + #ifdef mips #define MIPS 1 #endif *************** *** 56,84 **** #ifdef vax #define VAX 1 #endif ! #endif ! #endif ! #endif ! ! #ifdef MIPS ! #ifndef MIPSEL ! #define BIGMIPS 1 ! #define BIGENDIAN 1 ! #endif ! #endif ! ! /* If BIGENDIAN is defined, then architecture is big endian, otherwise it is ! little endian. UNSIGNED_FIELDSx defines bit fields in 32-bit words from ! least signigicant to most significant bits. ! */ ! ! #ifdef BIGENDIAN ! #define UNSIGNED_FIELDS2( a, b ) unsigned b; unsigned a ! #define UNSIGNED_FIELDS3( a, b, c ) unsigned c; unsigned b; unsigned a ! #else ! #define UNSIGNED_FIELDS2( a, b ) unsigned a; unsigned b ! #define UNSIGNED_FIELDS3( a, b, c ) unsigned a; unsigned b; unsigned c ! #endif /* The Scheme->C installer may elect to have arithmetic overflow handled gracefully on either the MIPS or the VAX implementations. The default --- 61,97 ---- #ifdef vax #define VAX 1 #endif ! #ifdef sun ! # ifdef sparc ! # define SPARC 1 ! # else ! # ifdef mc68000 ! # define SUN3 1 ! # endif ! # endif ! #endif ! #ifdef i386 ! #define I386 1 ! #endif ! #ifdef apollo ! # ifdef _ISP_A88K ! # define PRISM 1 ! # else ! # define APOLLO 1 ! # endif ! #endif ! #ifdef sony_news ! #define SONYNEWS ! #endif ! ! #endif /* PRISM */ ! #endif /* APOLLO */ ! #endif /* I386 */ ! #endif /* SUN3 */ ! #endif /* SPARC */ ! #endif /* VAX */ ! #endif /* TITAN */ ! #endif /* MIPS */ /* The Scheme->C installer may elect to have arithmetic overflow handled gracefully on either the MIPS or the VAX implementations. The default *************** *** 96,101 **** --- 109,118 ---- typedef jmp_buf sc_jmp_buf; #define CPUTYPE MIPS #define DOUBLE_ALIGN 1 + #ifndef MIPSEL + #define BIGMIPS 1 + #define BIGENDIAN 1 + #endif #endif #ifdef TITAN *************** *** 102,107 **** --- 119,125 ---- #include typedef jmp_buf sc_jmp_buf; #define CPUTYPE TITAN + #undef MATHTRAPS #endif #ifdef VAX *************** *** 118,123 **** --- 136,218 ---- #define CPUTYPE VAX #endif + #ifdef APOLLO + #include + typedef jmp_buf sc_jmp_buf; + #define CPUTYPE APOLLO + #define BIGENDIAN + #endif + + #ifdef PRISM + /* Use our own setjmp/longjmp so we can make sure all the registers + are saved that need to be saved, namely, .10 through .23, + plus the signal mask, return PC, and PSWs. + + The layout of these registers in the array is described in prism.asm. + */ + typedef int sc_jmp_buf[18]; + #define CPUTYPE PRISM + #define BIGENDIAN + #endif + + #ifdef SPARC + typedef int sc_jmp_buf[2+7+8+8+1+1]; + #define DOUBLE_ALIGN 1 + #define CPUTYPE SPARC + #define BIGENDIAN + #undef MATHTRAPS + #define MATHTRAPS 0 + #endif + + #ifdef SUN3 + #include + typedef jmp_buf sc_jmp_buf; + #define CPUTYPE SUN3 + #define BIGENDIAN + #undef MATHTRAPS + #define MATHTRAPS 0 + #endif + + #ifdef NeXT + #include + typedef jmp_buf sc_jmp_buf; + #define CPUTYPE NeXT + #define BIGENDIAN + #undef MATHTRAPS + #define MATHTRAPS 0 + #endif + + #ifdef I386 + #include + typedef jmp_buf sc_jmp_buf; + #define CPUTYPE I386 + #undef MATHTRAPS + #define MATHTRAPS 0 + #endif + + #ifdef SONYNEWS + #include + #include + typedef jmp_buf sc_jmp_buf; + #define CPUTYPE MIPS + #define DOUBLE_ALIGN 1 + #define BIGENDIAN + #endif + + + /* If BIGENDIAN is defined, then architecture is big endian, otherwise it is + little endian. UNSIGNED_FIELDSx defines bit fields in 32-bit words from + least signigicant to most significant bits. + */ + + #ifdef BIGENDIAN + #define UNSIGNED_FIELDS2( a, b ) unsigned b; unsigned a + #define UNSIGNED_FIELDS3( a, b, c ) unsigned c; unsigned b; unsigned a + #else + #define UNSIGNED_FIELDS2( a, b ) unsigned a; unsigned b + #define UNSIGNED_FIELDS3( a, b, c ) unsigned a; unsigned b; unsigned c + #endif + /* The data encoding scheme is similar to that used by Vax NIL and T, where all objects are represented by 32-bit pointers, with a "low tag" encoded in the two least significant bits encoding the type. All objects are *************** *** 226,231 **** --- 321,346 ---- #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) #endif + #ifdef apollo + #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) + #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) + #endif + #ifdef SPARC + #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) + #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) + #endif + #ifdef SUN3 + #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) + #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) + #endif + #ifdef NeXT + #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) + #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) + #endif + #ifdef I386 + #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) + #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) + #endif /* Fixed point numbers are encoded in the address portion of the pointer. The value is obtained by arithmetically shifting the pointer value two bits to *************** *** 636,643 **** --- 751,786 ---- When the procedure is exited, sc_stacktrace is restored. In order to assure that sc_stacktrace always points to a valid entry, the list is maintained by subroutines (compilers want to optimize it out!). + + In dobacktrace(), the stack is traced by calling C-UNSIGNED-REF + to get the prevstacktrace pointer. The problem with this is that + C-UNSIGNED-REF (aka scrt4_c_2dunsigned_2dref) uses MUNSIGNED, which + uses T_U, which masks out the least significant two bits of the pointer. + The trick is to get an implementation independent method of aligning + the stacktrace structure. Most compilers at least align the structure + with an even address, but only some will align it on a four-byte boundary. + + The macro ALIGN4(t,x) declares "x" to be a pointer to "t", aligned on + a 4-byte boundary. If nothing special needs to be done, then the default + definition can be used. + */ + + #ifdef APOLLO + /* On an Apollo, things are usually aligned properly on the stack, + but after an interrupt, things can get screwy, and even doubles + can end up non-longword aligned. To be safe, we need to align + everything on a longword boundary ourselves. */ + #define IDENT(a) a + #define CAT(a,b) IDENT(a)b + #define ALIGN4(t,x) char CAT(x,buf)[sizeof(t) + sizeof(long)];\ + t& x = * (t*) ((unsigned)CAT(x,buf) & ~(sizeof(long)-1)) + #endif + /* the rest of the world does not need to worry about such matters */ + #ifndef ALIGN4 + #define ALIGN4(t,x) t x + #endif struct STACKTRACE { /* Stack trace back record */ struct STACKTRACE* prevstacktrace; TSCP procname; *************** *** 646,652 **** extern struct STACKTRACE *sc_stacktrace; ! #define PUSHSTACKTRACE( procedure ) struct STACKTRACE st; \ sc_pushtrace( &st, (procedure) ) #define POPSTACKTRACE( exp ) return( sc_poptrace( &st, (exp) ) ) --- 789,795 ---- extern struct STACKTRACE *sc_stacktrace; ! #define PUSHSTACKTRACE( procedure ) ALIGN4(struct STACKTRACE, st); \ sc_pushtrace( &st, (procedure) ) #define POPSTACKTRACE( exp ) return( sc_poptrace( &st, (exp) ) ) *************** *** 744,749 **** --- 887,907 ---- #ifndef VECTOR_ELEMENT #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) #endif + #ifdef apollo + #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) + #endif + #ifdef SPARC + #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) + #endif + #ifdef I386 + #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) + #endif + #ifdef SUN3 + #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) + #endif + #ifdef NeXT + #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) + #endif #define PROCEDURE_REQUIRED( tscp ) (TX_U( tscp )->procedure.required) #define PROCEDURE_OPTIONAL( tscp ) (TX_U( tscp )->procedure.optional) *************** *** 887,895 **** #define IDIFFERENCE( a, b ) (a - b) #define INEGATE( a ) (- a) #define ITIMES( a, b ) (a * b) ! #endif - #if (MATHTRAPS && (CPUTYPE == MIPS || CPUTYPE == VAX)) #define IPLUS( a, b ) sc_iplus( a, b ) #define IDIFFERENCE( a, b ) sc_idifference( a, b ) #define ITIMES( a, b ) sc_itimes( a, b ) --- 1045,1053 ---- #define IDIFFERENCE( a, b ) (a - b) #define INEGATE( a ) (- a) #define ITIMES( a, b ) (a * b) ! ! #else #define IPLUS( a, b ) sc_iplus( a, b ) #define IDIFFERENCE( a, b ) sc_idifference( a, b ) #define ITIMES( a, b ) sc_itimes( a, b ) *************** *** 920,935 **** significant 8 bits of the extended object header. */ ! #define UNKNOWNCALL( proc, argc ) (sc_unknownargc = argc, \ ! sc_unknownproc[ 1 ] = proc, \ ! sc_unknownproc[ \ ! (UNSI_GNED( \ ! sc_unknownproc[ TSCPTAG( proc ) ] ) \ == (argc*256+PROCEDURETAG)) ]) /* Inline type conversions */ ! #define FLT_FIX( flt ) C_FIXED( (int)(FLOAT_VALUE( flt )) ) #define FIX_FLT( fix ) MAKEFLOAT( (FLOATTYPE)(FIXED_C( fix )) ) #define FIX_FLTV( fix ) ((FLOATTYPE)(FIXED_C( fix ))) #define FLTV_FLT( flt ) MAKEFLOAT( flt ) --- 1078,1109 ---- significant 8 bits of the extended object header. */ ! #define UNKNOWNCALL( proc, argc ) \ ! (sc_unknownargc = argc, sc_unknownproc[ 1 ] = proc, \ ! sc_unknownproc[(PROCEDURE_REQUIRED(sc_unknownproc[ TSCPTAG(proc) ]) == argc\ ! && ! PROCEDURE_OPTIONAL(sc_unknownproc[ TSCPTAG( proc )]))]) ! /* UNSI_GNED(sc_unknownproc[ TSCPTAG( proc ) ] ) \ == (argc*256+PROCEDURETAG)) ]) + */ /* Inline type conversions */ ! /* round a floating point number to the nearest integer */ ! #ifdef apollo ! #include ! /* Apollo SR10.2, with cc 6.7: rint() returns a bogus value (e.g., 0.9 ! is "rounded" to 0.899902). ! If Apollo does not fix rint() soon, then we should write our own. ! */ ! #define rint(x) floor((x) + 0.5) ! #define ROUND(x) ((int) rint(x)) ! #endif ! ! #ifndef ROUND ! #define ROUND(x) ((int) (x)) ! #endif ! ! #define FLT_FIX( flt ) C_FIXED( ROUND(FLOAT_VALUE( flt )) ) #define FIX_FLT( fix ) MAKEFLOAT( (FLOATTYPE)(FIXED_C( fix )) ) #define FIX_FLTV( fix ) ((FLOATTYPE)(FIXED_C( fix ))) #define FLTV_FLT( flt ) MAKEFLOAT( flt ) *************** *** 978,985 **** --- 1152,1168 ---- definitions needed by a SCHEME->C program. */ + #ifdef PRISM + /* As explained in heap.c, it is important to declare the function prototype, + so the compiler passes the floating point argument in a register, rather + than on the stack. + */ + extern TSCP sc_makefloat32(float); + extern TSCP sc_makefloat64(double); + #else extern TSCP sc_makefloat32(); extern TSCP sc_makefloat64(); + #endif extern TSCP sc_cons(); extern int sc_unknownargc; extern TSCP sc_unknownproc[ 4 ]; *** /dev/null Thu Oct 31 13:46:27 1991 --- scrt/prism.asm Wed Oct 23 16:33:12 1991 *************** *** 0 **** --- 1,387 ---- + * prism.asm - Apollo Prism (DN10000) specific module for DEC's Scheme->C + * + * This file implements the assembly language part of the Prism port, + * specifically for the DN10000. + * + * Included are all the necessary math routines to catch integer overflow. + * + * NOTE: Don't even try to read this file if you do not understand + * how an Apollo Prism (also called an AT, for Advanced Technology; + * perhaps Apollo thinks the Prism is as good as an IBM PC AT :-) works. + * I have tried to optimize the parallel operations, such as branch and + * call shadows, and combining integer and floating point operations. + * (The former are common; the latter are rare in this file.) + * + * The sematics of b.sa are completely different from b.sn, and the + * subtle differences are too lengthy to discuss here. Read the + * various Apollo manuals, such as the AT Assembler Reference and + * the AT Technical Reference. + * + * Apollo's setjmp/longjmp do not permit jumps to random locations in the + * stack, so we must write our own. On the DN3000 (M68K), we can get away + * with simply altering the stack and frame pointers (A6 and A7) before + * calling longjmp, but on the Prism this does not work because longjmp + * only jumps to a valid stack frame. I tried modifying call/cc to + * restore the stack and registers before calling longjmp(), but this + * does not work because it changes the data base register, which messes + * up the call to longjmp. The simplest solution is to reimplemen]t + * setjmp and longjmp. + * + * Another reason to write our own setjmp/longjmp is to make sure all + * the registers are saved properly. The standard jmp_buf does not have + * enough room to save all the needed registers. + * + * Ray Lischner (uunet!mntgfx!lisch) + * 1 May 1990 + + module sc_prism + + export.f prism_stack_frame + export.p sc_longjmp + export.f sc_setjmp + export.p sc_regs + export.f sc_iplus + export.f sc_idifference + export.f sc_inegate + export.f sc_itimes + + import.f sc_makefloat64 + import.f sigblock + import.f sigsetmask + + data + + * set up ECBs for all the functions that need one + data_frame equ * + + sc_setjmp procedure ok + .0 = sc$setjmp ; get the relocatable address of the routine + .1 = .sf ; save the old stack frame + .2 = #data_frame ; get the relocatable data frame + b.sa [.0] ; branch to the real routine + [--.sf,#16] = .1 ; push the old .SF onto the stack + + sc_longjmp procedure ok + .0 = sc$longjmp ; get the relocatable address of the routine + .1 = .sf ; save the old stack frame + .2 = #data_frame ; get the relocatable data frame + b.sa [.0] ; branch to the real routine + [--.sf,#16] = .1 ; push the old .SF onto the stack + + sc_idifference procedure ok + .0 = sc$idifference ; get the relocatable address of the routine + .1 = .sf ; save the old stack frame + .2 = #data_frame ; get the relocatable data frame + b.sa [.0] ; branch to the real routine + [--.sf,#16] = .1 ; push the old .SF onto the stack + + sc_inegate procedure ok + .0 = sc$inegate ; get the relocatable address of the routine + .1 = .sf ; save the old stack frame + .2 = #data_frame ; get the relocatable data frame + b.sa [.0] ; branch to the real routine + [--.sf,#16] = .1 ; push the old .SF onto the stack + + sc_iplus procedure ok + .0 = sc$iplus ; get the relocatable address of the routine + .1 = .sf ; save the old stack frame + .2 = #data_frame ; get the relocatable data frame + b.sa [.0] ; branch to the real routine + [--.sf,#16] = .1 ; push the old .SF onto the stack + + sc_itimes procedure ok + .0 = sc$itimes ; get the relocatable address of the routine + .1 = .sf ; save the old stack frame + .2 = #data_frame ; get the relocatable data frame + b.sa [.0] ; branch to the real routine + [--.sf,#16] = .1 ; push the old .SF onto the stack + + * jump table for the ECBs + sc$setjmp data.l sc$$setjmp + sc$longjmp data.l sc$$longjmp + sc$idifference data.l sc$$idifference + sc$inegate data.l sc$$inegate + sc$iplus data.l sc$$iplus + sc$itimes data.l sc$$itimes + + * relocation table for the external functions + sc$makefloat64 data.l sc_makefloat64 + sig$setmask data.l sigsetmask + sig$block data.l sigblock + proc + + *********************************************************************** + * int prism_stack_frame(void) + * Return the caller's stack frame pointer. See the STACKPTR macro + * in heap.h for how this is called. + + prism_stack_frame procedure ok + b.sa [.return] + .0 = .sf + + + *********************************************************************** + * int sc_setjmp(jmp_buf buf) + * Save the current signal mask, processor status words, and preserved + * registers in the caller-supplied buffer, and return zero. + + sc$$setjmp procedure name="sc_setjmp",return=save,stack=(),save=1$ + [.sf,4] = .4 + [.sf,8] = .return + [.sf,12] = .10 + .10 = .2 + using .10, data_frame + 1$ .0 = .ipsw ; and the processor status words + [.4++] = .0 + .0 = .fppsw + [.4++] = .0 + .0 = [.sf,12] ; old value of .10 + [.4++] = .0 + [.4++] = .11 + [.4++] = .12 + [.4++] = .13 + [.4++] = .14 + [.4++] = .15 + [.4++] = .16 + [.4++] = .17 + [.4++] = .18 + [.4++] = .19 + [.4++] = .20 + [.4++] = .21 + [.4++] = .return + .0 = [.sf] + [.4++] = .0 + + .3 = sig$block ; and the current signal mask + .return = call.sa [.3] ; sigblock(0) + .4 = .null + .4 = [.sf,4] + [.4++] = .0 + + .10 = [.sf,12] ; restore the saved registers + .return = [.sf,8] + .0 = .null + b.sa [.return] ; return(0) + .sf = [.sf] + + drop .10 + endp + + * void longjmp(jmp_buf buf, int rtn) + * Jump to the location saved by a previous call to setjmp(), such that + * it looks to the caller of setjmp() as though setjmp returned "rtn". + * If "rtn" is zero, one is returned. + + sc$$longjmp procedure name="sc_longjmp",return=save,stack=(),save=1$ + [.sf,8] = .return + using .2, data_frame + 1$ .cc = .5 + .0 = [.4++] + bnz.sf 2$ ; make sure the return value is non-zero + .5 = #1 + 2$ .ipsw = .0 + .0 = [.4++] + .fppsw = .0 + .10 = [.4++] + .11 = [.4++] + .12 = [.4++] + .13 = [.4++] + .14 = [.4++] + .15 = [.4++] + .16 = [.4++] + .17 = [.4++] + .18 = [.4++] + .19 = [.4++] + .20 = [.4++] + .21 = [.4++] + .0 = [.4++] + [.sf,8] = .0 ; save the return PC + .0 = [.4++] + [.sf] = .0 ; save .sf + [.sf,4] = .5 ; save return value + + .3 = sig$setmask ; restore the signal mask + .return = call.sa [.3] + .4 = [.4] + + .0 = [.sf,4] ; return the user-supplied "rtn" + .return = [.sf,8] + b.sa [.return] + .sf = [.sf] + endp + + *********************************************************************** + * void sc_regs(int regs[12]) + * sc_regs stores the values of .10 - .21 in the caller supplied buffer. + * These are the "callee" save registers that need to be examined during + * garbage collection. + + sc_regs procedure ok + [.4++] = .10 + [.4++] = .11 + [.4++] = .12 + [.4++] = .13 + [.4++] = .14 + [.4++] = .15 + [.4++] = .16 + [.4++] = .17 + [.4++] = .18 + [.4++] = .19 + [.4++] = .20 + b.sa [.return] + [.4] = .21 + endp + + *********************************************************************** + * The following routines are for doing arithmetic on tagged numbers. + * The input arguments are tagged integers, that is, integers shifted + * left by two bits. (Except for sc_itimes, where only the second + * argument, b, is shifted.) This makes it easier to check for overflow, + * but we must unshift the values before calling sc_makefloat64(). + * + * When the result of any operation overflows, the operands are converted + * to floating point, and the operation is repeated. The floating point + * result is then passed to sc_makefloat64() to produce a float object + * to return. + + + * int sc_iplus(int a, int b) + * returns the integer sum, a + b, where a and b are the two + * integer arguments, unless integer overflow occurs, then returns + * (unsigned int) sc_makefloat64( (double)a + (double)b ) instead. + + sc$$iplus procedure name="sc_iplus",return=save,stack=(),save=1$ + [.sf,8] = .return + * add the arguments + 1$ .0.cc = .4 + .5 ; try adding the arguments as integers + .4 = .4 SHRA #2 ; wait 1 cycle until CCs set + bnv.sf 2$ ; return if the integer operation worked + .5 = .5 SHRA #2 ; otherwise keep working + .fs0.i = .5 ; convert the integers to floating point + .fs1.i = .4 + .fd8 = float(.fs1.i) + .fd0 = float(.fs0.i) + * get ready to call makefloat64, while adding the operands + .3 = sc$makefloat64, .fd8 += .fd0 + .return = call.sn [.3] ; call sc_makefloat64() + nop + .return = [.sf,8] ; pop the return PC + + 2$ b.sa [.return] ; return + .sf = [.sf] ; restore the old .SF + endp + + + * int sc_idifference(int a, int b) + * returns integer difference, a - b, where a and b are the two + * integer arguments, unless integer overflow occurs, then returns + * (unsigned int) sc_makefloat64( (double)a - (double)b ) instead. + + sc$$idifference procedure ok,name="sc_idifference" + [.sf,8] = .return + * subtract the arguments + 1$ .0.cc = .4 - .5 ; try subtracting the arguments as integers + .4 = .4 SHRA #2 ; wait 1 cycle until CCs set + bnv.sf 2$ ; return if the integer operation worked + .5 = .5 SHRA #2 ; otherwise keep working + .fs0.i = .5 ; convert the integers to floating point + .fs1.i = .4 + .fd8 = float(.fs1.i) + .fd0 = float(.fs0.i) + * get ready to call makefloat64, while subtracting the operands + .3 = sc$makefloat64, .fd8 -= .fd0 + .return = call.sn [.3] ; call sc_makefloat64() + nop + .return = [.sf,8] ; pop the return PC + + 2$ b.sa [.return] ; return + .sf = [.sf] ; restore the old .SF + endp + + * int sc_inegate(int a) + * returns integer negation, -a, where a is the integer + * argument, unless integer overflow occurs, then returns + * (unsigned int) sc_makefloat64( -(double)a) instead. + + sc$$inegate procedure ok,name="sc_inegate" + [.sf,8] = .return + * negate the argument + 1$ .0.cc = -.4 ; try negating the argument as an integer + .4 = .4 SHRA #2 ; wait 1 cycle until CCs set + bnv.sf 2$ ; return if the integer operation worked + .fs0.i = .4 ; otherwise keep working + .fd8 = float(.fs0.i) ; convert the argument to floating point + * get ready to call makefloat64, while negating the argument + .3 = sc$makefloat64, .fd8 = -.fd8 + .return = call.sn [.3] ; call sc_makefloat64() + nop + .return = [.sf,8] ; pop the return PC + + 2$ b.sa [.return] ; return + .sf = [.sf] ; restore the old .SF + endp + + * sc_itimes(int a, int b) + * returns integer procuct, a * b, where a and b are the two + * integer arguments, unless integer overflow occurs, then returns + * (unsigned int) sc_makefloat64( (double)a * (double)b ) instead. + * Unlike the previous arithmetic functions, only "b" has been shifted. + * + * This is a pain on a Prism because we need to use the floating + * point unit for the integer multiply, and that means we cannot + * set the integer condition codes. Instead, we do a normal + * floating point multiply and explicitly check the result to see + * if it fits into an integer. If not, we divide by 4 to get the + * true result. Note that this does not affect the precision + * of the result. + + sc$$itimes procedure name="sc_itimes",return=save,stack=(),save=1$ + [.sf,8] = .return + 1$ .fs0.i = .4 ; load floating point registers for the + .fs1.i = .5 ; multiplication + .fd8 = float(.fs0.i) + .fd2 = float(.fs1.i) + * do the multiply; at the same time, load sc_makefloat64's address, to + * get ready for calling it, in case the multiply overflows + .3 = sc$makefloat64, .fd8 *= .fd2 + + * The floating point constants do not change, so we can put them in + * the shared text segment. Change the address base to .PC, so we + * use PC-relative addressing. + drop .2 + + * look for overflow by comparing with the maximum allowable integer + .fd2 = maxint ; get maxint + .fcc = .fd8 ? .fd2 + bfgt.sf 2$ ; see if the result fits into an integer + .fd2 = minint.fd + .fcc = .fd8 ? .fd2 + bflt.sf 2$ + + .fs0.i = round(.fd8) ; yes, so convert it to an integer + b.sa 3$ ; and return + .0 = .fs0.i + + 2$ .fd0 = four + .fd8 /= .fd0 ; get the real floating point value + .return = call.sn [.3] ; call sc_makefloat64() + nop + .return = [.sf,8] ; pop the return PC + + 3$ b.sa [.return] ; return + .sf = [.sf] ; restore the old .SF + + * constant value for the division, above + four data.fd 4.0 + + * maximum and minimum possible integer, for comparison, above + maxint data.fd 2147483644.0 + + * The assembler seems to ignore the sign of a floating point constant. + * A Prism uses IEEE format, so the smallest possible integer + * is pretty easy to write in hexadecimal. + *minint data.fd -2147483648.0 + minint data.q h'C1E00000, h'00000000 + endp + + end *** /dev/null Thu Oct 31 13:46:28 1991 --- scrt/prism.o.uu Wed Oct 23 16:33:13 1991 *************** *** 0 **** --- 1,82 ---- + begin 444 prism.o + M 90 ""8]YI@ K0 )0 L@ H 0 ! $R * ( + M$ "YT97AT @!@ ( 8 +8 !@ + M ! @ " N=6YW:6YD (!%@ " 18 < !%@ GX + M ' 0 @+F1A=&$ $ ! * 3( */@ "0 + M$ 0"YM:7( < %: @ N + M02!#X$$@0^)!($/D02!#YD$@0^A!($/J02!#P$$@1H%P (/ 02!&@7 + M !HMP $8&( E"+ -@A 8!< !&+7 @D, 68O< #E$$@0Y9!($.802 + M!#FD$@0YQ!($.>02!#H$$@0Z)!($.D02!#ID$@0ZA!($)# %FJD !JUP ( + M$ 1@!1""OT0MW /$**_1?R_ 0 Y $ _)\!! #D 023_P ?-CR 09/_ !\V + M/ X&( D#*,@@ BQ #$_\ 'V+7 @D, 68O< &K7 @0!&@%$(*_1"W< + M \0HK]%_+\! #D 0#\GP$$ .0!!)/_ !\V/(!!D_\ 'S8\ #@8@"0,IR" + M "+$ ,3_P ?8M< ""0P !9B]P :M< "! ?: 00@K]$K=P "P3$ #\GP$ + M .0! )/_ !\V/( X&( D#)<@@@BQ #$_\ 'V+7 @D, 68O< &K7 C\ + MGP$ .0! /R_ 00 Y $$D_\ 'S8\@ "3_P ?-CP@0>!B ) P3(("[#X < 3$ + M "3_P ?$[P" BJ< QL/@!DD_\ 'Q.\ @*K' (!,0 )/_ !\V' ((K# + M"P3$ #\'R$ .0! .P> "@$Q D_\ 'S ,@@ BQ #$_\ 'V+7 @D, 6 + M8O< ! $ $'?____ P> " &( %H! ' + M @!B 1@ @ _^V" ( A0 $( ( /_M@( " +, H " + M #_[8" @#' * _^P ( VP " /_L " .L !6 + M " #_[8" 8!X >! W(!\87O_X)# #@WE'!@'@!H$#<@'QA>_^0D, + M.#>4<& > %@0-R ?&%[_T"0P X-Y1P8!X 2! W(!\87O^\)# #@WE'!@ + M'@ X$#<@'QA>_Z@D, .#>4<& > "@0-R ?&%[_E"0P X-Y1P @!B ( + M A0 " ,< @#; ( LP " .L ( 0 . #DC + M6\;3 ! " @ * ! $ ! !@! $" !@ . /@ + M !H R #4 ( 4 " & ! 0 * $ /P ! %" , $F/>@! " + M0@0 @( P< 0 *P 0 BP ! /0$ (" + M +4 $ ! $ 'L 0 #A! " @ + M "G0 ! 4 ! !G $ RP0 @( + M FP 0 % 0 4P ! +4$ (" (\ + M $ T $ $8 0 "A! " @ ""0 ! + M A ! E $ >@0 @( =< 0 (P + M 0 @ ! %$$ (" &= $ ( $ + M 0 !(! " @ !:P ! % " 9 $ + M/ 0 @( 3H 0 !0 @ % ! # $ (" + M $' $ 4 ( \ 0 D! " @ + M T ! % " * $ & 0 @( + M )T 0 !0 @ !0 ! P$ (" !K + M $ 4 ( 0 &P #<+R]J96QL:6]T="]L;V-A;%]U + M !( !@ 0 'P 2 8 $ " $@ & ! + MA !( !@ 0 (@ 2 8 $ ", $@ & ! D "0 !@ 0 )0 B + M 8 $ "8 (P & ! O@ !( !@ 0 ,( 6 8 $ #& ' & ! + MR@ !X !@ 0 ,X @ 8 N9FEL90 "+__@ 9P%P #include #include #include #include /* Definitions for objects within sc */ --- 47,68 ---- /* External Definitions */ + #ifdef NeXT + #define sbrk my_sbrk + #endif extern char *sbrk(); extern char *getenv(); extern errno; /* C-library Error flag */ #include + #include #include + #ifndef SYSV #include + #else + #include + #endif #include /* Definitions for objects within sc */ *************** *** 75,106 **** extern etext; #ifdef MIPS #define ETEXT ((int)&etext) /* First address after text */ #ifdef BIGMIPS #include #include */ #define STACKBASE (int*)USERSTACK #else #include #include #define STACKBASE (int*)USRSTACK ! #endif ! #endif #ifdef TITAN #define ETEXT etext /* First address after text */ #include #define STACKBASE (int*)(MAXUSERADDR+1) #endif #ifdef VAX #define ETEXT ((int)&etext) /* First address after text */ #include #include #define STACKBASE (int*)USRSTACK #endif /* Global data structure for this module. */ ! static int emptyvector = VECTORTAG, ! emptystring[2] = {STRINGTAG, 0}; FILE *sc_stdin, /* Standard I/O Subroutine FILE pointers */ *sc_stdout, --- 82,211 ---- extern etext; #ifdef MIPS #define ETEXT ((int)&etext) /* First address after text */ + #ifndef sony_news #ifdef BIGMIPS #include #include */ + #define MACH_STRING "Big Endian MIPS" + #define CPU_STRING "R2000/R3000" + #define OS_STRING "RISCOS" #define STACKBASE (int*)USERSTACK #else #include #include + #define MACH_STRING "DECstation" + #define CPU_STRING "R2000/R3000" + #define OS_STRING "ULTRIX" #define STACKBASE (int*)USRSTACK ! #endif /* BIGMIPS */ ! #else ! #include ! #include ! #define MACH_STRING "Sony News3200" ! #define CPU_STRING "R3000" ! #define OS_STRING "NewsOS" ! #define STACKBASE (int*)USRSTACK ! #endif /* sony_news */ ! #endif /* MIPS */ ! #ifdef TITAN #define ETEXT etext /* First address after text */ #include #define STACKBASE (int*)(MAXUSERADDR+1) #endif + #ifdef VAX #define ETEXT ((int)&etext) /* First address after text */ #include #include #define STACKBASE (int*)USRSTACK + #define MACH_STRING "VAX" + #define CPU_STRING "VAX" + #define OS_STRING "ULTRIX" + #endif + + #ifdef apollo + # ifdef _ISP_A88K + # define PRISM 1 + # else + # define APOLLO 1 + # endif + #define ETEXT ((int)&etext) /* First address after text */ + #include + /* the stack back moves depending on shared libraries */ + #include + #include + #include + static proc2_$info_t sc_apollo_proc2; + #define STACKBASE ((int*) sc_apollo_proc2.stack_base) + #ifdef APOLLO + #define MACH_STRING "Apollo" + #define CPU_STRING "68K" + #define OS_STRING "Domain/OS" + #else + #define MACH_STRING "Apollo" + #define CPU_STRING "PRISM" + #define OS_STRING "Domain/OS" + #endif + #endif + + #ifdef SPARC + #define ETEXT ((int)&etext) /* First address after text */ + #include + #define STACKBASE (int*)USRSTACK + #define CPU_STRING "SPARC" + #ifdef sun + #define MACH_STRING "Sun4/SparcStation" + #define OS_STRING "SunOS" + #else + #define MACH_STRING "SparcClone" + #define OS_STRING "SparcOS" + #endif + #endif + + #ifdef SUN3 + #define ETEXT ((int)&etext) /* First address after text */ + #include + #include + #define STACKBASE (int*)USRSTACK + #define MACH_STRING "Sun3" + #define CPU_STRING "68K" + #define OS_STRING "SunOS" + #endif + + #ifdef NeXT + #define ETEXT ((int)get_etext()) + #include + #define STACKBASE (int*)USRSTACK + #define MACH_STRING "NeXT" + #define CPU_STRING "68K" + #define OS_STRING "NeXT OS" + #endif + + #ifdef ISC386IX + #if I386SHLIB + int *sc__etext; + #define ETEXT ((int)sc__etext) /* first address after text */ + #else + #define ETEXT ((int)&etext) /* First address after text */ + #endif + #include + #include /* probably should be elsewhere */ + #include + #define STACKBASE (int*)UVSTACK + #define MACH_STRING "AT/386" + #define CPU_STRING "Intel 386" + #define OS_STRING "System V.3.2" #endif + /* ditto for SCO */ /* Global data structure for this module. */ ! /* this struct must look like an SCOBJ */ ! static struct ! { ! UNSIGNED_FIELDS2( tag:8, length:24); ! } emptyvector, emptystring[2]; FILE *sc_stdin, /* Standard I/O Subroutine FILE pointers */ *sc_stdout, *************** *** 202,207 **** --- 307,313 ---- static init_procs() { + #ifndef SYSV INITIALIZEVAR( U_TX( ADR( t1030 ) ), ADR( sc_my_2drusage_v ), MAKEPROCEDURE( 0, *************** *** 211,216 **** --- 317,323 ---- MAKEPROCEDURE( 0, 0, sc_collect_2drusage, EMPTYLIST ) ); + #endif /* ! SYSV */ INITIALIZEVAR( U_TX( ADR( t1034 ) ), ADR( sc_collect_v ), MAKEPROCEDURE( 0, *************** *** 353,358 **** --- 460,478 ---- char *freebase; TSCP unknown; + #ifdef apollo + /* on an apollo, we get the stack top at run time */ + uid_$t me; + status_$t status; + proc2_$who_am_i(&me); + proc2_$get_info(me, &sc_apollo_proc2, sizeof(sc_apollo_proc2), &status); + if (status.all != status_$ok && status.all != proc2_$is_current) + { + error_$print(status); + exit(2); + } + #endif + sc_limit = sclimit; sc_heappages = scheap*(ONEMB/PAGEBYTES); sc_maxheappages = scmaxheap*(ONEMB/PAGEBYTES); *************** *** 379,384 **** --- 499,506 ---- sc_mutex = 0; sc_pendingsignals = 0; sc_emptylist = EMPTYLIST; + emptyvector.tag = VECTORTAG; + emptystring[0].tag = STRINGTAG; sc_emptyvector = U_T( &emptyvector, EXTENDEDTAG ); sc_emptystring = U_T( emptystring, EXTENDEDTAG ); sc_falsevalue = FALSEVALUE; *************** *** 408,417 **** sc_globals = addtoSCPTRS( sc_globals, &sc_unknownproc[ i ] ); } module_initialized = 1; ! if (sc_gcinfo) fprintf( stderr, "***** SCGCINFO = %d SCHEAP = %d SCMAXHEAP = %d SCLIMIT = %d\n", sc_gcinfo, scheap, scmaxheap, sclimit ); } /* A block of storage is added to the heap by the following function. Side --- 530,545 ---- sc_globals = addtoSCPTRS( sc_globals, &sc_unknownproc[ i ] ); } module_initialized = 1; ! if (sc_gcinfo) { ! #ifdef sun ! /* in SunOS, stderr is line buffered, which causes some unwanted */ ! /* malloc.. */ ! setbuf(stderr, (char*)0); ! #endif fprintf( stderr, "***** SCGCINFO = %d SCHEAP = %d SCMAXHEAP = %d SCLIMIT = %d\n", sc_gcinfo, scheap, scmaxheap, sclimit ); + } } /* A block of storage is added to the heap by the following function. Side *************** *** 783,788 **** --- 911,918 ---- sc_mutex = 0; sc_pendingsignals = 0; sc_emptylist = EMPTYLIST; + emptyvector.tag = VECTORTAG; + emptystring[0].tag = STRINGTAG; sc_emptyvector = U_T( &emptyvector, EXTENDEDTAG ); sc_emptystring = U_T( emptystring, EXTENDEDTAG ); sc_falsevalue = FALSEVALUE; *************** *** 872,877 **** --- 1002,1008 ---- scrt6_error( sc_string_2d_3esymbol( sc_cstringtostring( symbol ) ), sc_cstringtostring( format ), scrt1_reverse( argl ) ); + va_end( argp ); } /* The following function returns informations about the implementation. The *************** *** 889,921 **** sc_cons( sc_cstringtostring( "Scheme->C" ), sc_cons( ! sc_cstringtostring( "01nov91jfb" ), sc_cons( ! #ifdef MIPS ! #ifdef BIGENDIAN ! sc_cstringtostring( "Big Endian MIPS" ), ! #else ! sc_cstringtostring( "DECstation" ), ! #endif ! #endif ! #ifdef TITAN ! sc_cstringtostring( "WRL-TITAN" ), ! #endif ! #ifdef VAX ! sc_cstringtostring( "VAX" ), ! #endif sc_cons( ! #ifdef MIPS ! sc_cstringtostring( "R2000/R3000" ), ! #endif ! #ifdef TITAN ! sc_cstringtostring( "BYTE-ADDRESSED" ), ! #endif ! #ifdef VAX ! sc_cstringtostring( "VAX" ), ! #endif sc_cons( ! sc_cstringtostring( "ULTRIX" ), sc_cons( FALSEVALUE, EMPTYLIST --- 1020,1032 ---- sc_cons( sc_cstringtostring( "Scheme->C" ), sc_cons( ! sc_cstringtostring( "01nov91jfb+MCC01" ), sc_cons( ! sc_cstringtostring( MACH_STRING ), sc_cons( ! sc_cstringtostring( CPU_STRING ), sc_cons( ! sc_cstringtostring( OS_STRING ), sc_cons( FALSEVALUE, EMPTYLIST *************** *** 927,929 **** --- 1038,1085 ---- ) ); } + + #ifdef NeXT + #include + #include + + char *my_current_brk = 0; + char *my_end_brk = 0; + + char * + my_sbrk(int incr) + { + char *temp, *ptr; + kern_return_t rtn; + + if (my_current_brk == 0) { + if ((rtn = vm_allocate(task_self(), (vm_address_t *) & my_current_brk, + vm_page_size, 1)) != KERN_SUCCESS) { + mach_error("my_sbrk: vm_allocate failed", rtn); + return ((char *)-1); + } + my_end_brk = my_current_brk + vm_page_size; + } + if (incr == 0) return (my_current_brk); + more: + ptr = my_current_brk + incr; + if (ptr <= my_end_brk) { + temp = my_current_brk; + my_current_brk = ptr; + return (temp); + } else { + if ((rtn = vm_allocate(task_self(), (vm_address_t *) &ptr, + vm_page_size, 1)) != KERN_SUCCESS) { + mach_error("my_sbrk: vm_allocate failed", rtn); + return ((char *)-1); + } + if (ptr != my_end_brk) { + fprintf(stderr, "my_sbrk: internal error\n"); + fflush(stderr); + return ((char *)-1); + } + my_end_brk = ptr + vm_page_size; + goto more; + } + } + #endif /* NeXT */ *** 1.1 1991/10/23 18:49:30 --- scrt/scrt7.sc 1991/10/31 17:40:38 *************** *** 125,130 **** --- 125,133 ---- token-vector) ((char=? char #\\ ) (character)) + ((char=? char #\!) + (do () ((char=? (next-char) #\newline))) + (token) ) ((char=? char #\T) #t) ((char=? char #\F) *** 1.1 1991/10/23 18:49:32 --- scrt/signal.c 1991/10/23 21:30:51 *************** *** 49,58 **** --- 49,62 ---- #include "apply.h" #include "signal.h" #include "/usr/include/signal.h" + #ifdef apollo + #include + #endif extern TSCP scrt4_onsignal2(); #ifdef MIPS + #ifndef sony_news #ifdef BIGMIPS #include #include *************** *** 60,65 **** --- 64,73 ---- #include #include #endif + #else + #include + #include + #endif #endif int sc_mutex; /* Mutual exclusion flag */ *************** *** 97,106 **** --- 105,119 ---- hardware traps. */ + #ifdef SYSV + void sc_onsignal1( signal ) + int signal; + #else void sc_onsignal1( signal, code, scp ) int signal, code; struct sigcontext* scp; + #endif { int i; struct { /* Save sc_unknowncall's state here */ *************** *** 110,115 **** --- 123,136 ---- } save; if (sc_mutex == 0 && sc_collecting == 0) { + #ifdef SYSV + /* Reset the signal, might be more prudent later? */ + { + extern TSCP scrt4_signals_v; + scrt4_signal(INT_TSCP(signal), + VECTOR_ELEMENT(scrt4_signals_v, INT_TSCP(signal))); + } + #endif /* Save sc_unknowncall's state */ for (i = 0; i < 4; i++) save.proc[ i ] = sc_unknownproc[ i ]; for (i = 0; i < MAXARGS; i++) save.arg[ i ] = sc_arg[ i ]; *************** *** 123,129 **** --- 144,154 ---- } else { /* Signal must be defered */ + #ifdef SYSV + sighold( signal ); + #else sigblock( 1< + + ! + ! This misnamed function is responsible for providing the + ! top of stack address, via macro STACKPTR, to the continuation + ! builder and the heap manager. Because both of these functions + ! immediately begin examining the memory on the stack, the register + ! windows are flushed to memory so their values will be saved in + ! heap allocated continuations and seen by the garbage collector. + ! + .global _sc_processor_register + _sc_processor_register: + ta 3 ! flush register windows + jmp %o7+8 ! return + add %sp, 0, %o0 ! return stack pointer + + ! + ! Save the current environment in a heap allocated continuation. + ! + .global _sc_setjmp + _sc_setjmp: + st %o6, [%o0 + 0] ! save stack pointer + st %o7, [%o0 + 4] ! save continuation pointer + st %g1, [%o0 + 8] ! save global registers + st %g2, [%o0 + 12] ! these may be allocated for + st %g3, [%o0 + 16] ! caller saves registers or + st %g4, [%o0 + 20] ! for global values. + st %g5, [%o0 + 24] + st %g6, [%o0 + 28] + st %g7, [%o0 + 32] + st %l0, [%o0 + 36] ! save local registers + st %l1, [%o0 + 40] ! the sunos setjmp uses + st %l2, [%o0 + 44] ! the register windows to + st %l3, [%o0 + 48] ! save these, we can't. + st %l4, [%o0 + 52] + st %l5, [%o0 + 56] + st %l6, [%o0 + 60] + st %l7, [%o0 + 64] + st %i0, [%o0 + 68] + st %i1, [%o0 + 72] + st %i2, [%o0 + 76] + st %i3, [%o0 + 80] + st %i4, [%o0 + 84] + st %i5, [%o0 + 88] + st %i6, [%o0 + 92] + st %i7, [%o0 + 96] + mov %y, %o2 ! fetch %y, whatever it is + st %o2, [%o0 + 100] ! and save it + + add %o0, %g0, %i0 ! save o0 in i0 + clr %o0 + mov SYS_sigblock,%g1 + t 0 + st %o0, [%i0 + 104] ! save signal mask + + jmp %o7+8 ! return + add %g0, %g0, %o0 ! return 0 + + ! + ! Restore an environment from a heap allocated continuation. + ! + .global _sc_longjmp + _sc_longjmp: + add %o0, %g0, %i0 ! save o0 in i0 + add %o1, %g0, %i1 ! save o1 in i1 + ld [%o0 + 104], %o0 + mov SYS_sigsetmask, %g1 + t 0 ! sigsetmask(oldmask) + add %i0, %g0, %o0 ! restore o0 + add %i1, %g0, %o1 ! restore o1 + + ta 3 ! flush register windows + ld [%o0 + 0], %o6 ! restore stack pointer + ld [%o0 + 4], %o7 ! load continuation pointer + ld [%o0 + 8], %g1 ! restore global registers + ld [%o0 + 12], %g2 + ld [%o0 + 16], %g3 + ld [%o0 + 20], %g4 + ld [%o0 + 24], %g5 + ld [%o0 + 28], %g6 + ld [%o0 + 32], %g7 + ld [%o0 + 36], %l0 ! restore local frame from stack + ld [%o0 + 40], %l1 + ld [%o0 + 44], %l2 + ld [%o0 + 48], %l3 + ld [%o0 + 52], %l4 + ld [%o0 + 56], %l5 + ld [%o0 + 60], %l6 + ld [%o0 + 64], %l7 + ld [%o0 + 68], %i0 + ld [%o0 + 72], %i1 + ld [%o0 + 76], %i2 + ld [%o0 + 80], %i3 + ld [%o0 + 84], %i4 + ld [%o0 + 88], %i5 + ld [%o0 + 92], %i6 + ld [%o0 + 96], %i7 + ld [%o0 + 100], %o2 ! restore %y, whatever it is + mov %o2, %y + jmp %o7+8 ! return + add %o1, %g0, %o0 ! return arg + *** /dev/null Thu Oct 31 13:47:08 1991 --- scrt/sun3.s Wed Oct 23 16:33:16 1991 *************** *** 0 **** --- 1,69 ---- + | + | SCHEME->C + | + | Sun3 assembly code. + | + + | + | Copyright 1989 Digital Equipment Corporation + | All Rights Reserved + | + | Permission to use, copy, and modify this software and its documentation is + | hereby granted only under the following terms and conditions. Both the + | above copyright notice and this permission notice must appear in all copies + | of the software, derivative works or modified versions, and any portions + | thereof, and both notices must appear in supporting documentation. + | + | Users of this software agree to the terms and conditions set forth herein, + | and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free + | right and license under any changes, enhancements or extensions made to the + | core functions of the software, including but not limited to those affording + | compatibility with other hardware or software environments, but excluding + | applications which incorporate this software. Users further agree to use + | their best efforts to return to Digital any such changes, enhancements or + | extensions that they make and inform Digital of noteworthy uses of this + | software. Correspondence should be provided to Digital at: + | + | Director of Licensing + | Western Research Laboratory + | Digital Equipment Corporation + | 100 Hamilton Avenue + | Palo Alto, California 94301 + | + | This software may be distributed (but not offered for sale or transferred + | for compensation) to third parties, provided such third parties agree to + | abide by the terms and conditions of this notice. + | + | THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL + | WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF + | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT + | CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL + | DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR + | PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS + | ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS + | SOFTWARE. + | + + | + | sc_a2to5d2to7 + | + | sc_a2to5d2to7( a ) + | will return the contents of A2, ..., A5, D2, ..., D7 starting at address 'a'. + | + | + .text + .globl _sc_a2to5d2to7 + .even + _sc_a2to5d2to7: + movl sp@(4),a0 + movl a2,a0@(0) + movl a3,a0@(4) + movl a4,a0@(8) + movl a5,a0@(12) + movl d2,a0@(16) + movl d3,a0@(20) + movl d4,a0@(24) + movl d5,a0@(28) + movl d6,a0@(32) + movl d7,a0@(36) + rts *** 1.1 1991/10/23 18:50:21 --- scsc/makefile-tail 1991/10/24 22:18:02 *************** *** 30,45 **** .c.o: ${CC} -c ${CFLAGS} -D${cpu} -I../scrt $*.c ${scc}: ${predef} sc-to-c: ${scc} ! Xsccomp: ${scc} ${sco} ${rt} ! ${CC} -o Xsccomp ${CFLAGS} ${sco} ${rt} -lm Xsccomp.heap: Xsccomp Xsccomp ../scrt/predef.sc ../scrt/objects.h ../scrt/libsc.a \ ../scrt/libsc_p.a ${cpu} Xsccomp.heap Xmv: mv Xsccomp sccomp --- 30,51 ---- .c.o: ${CC} -c ${CFLAGS} -D${cpu} -I../scrt $*.c + all: sccomp.heap + # $(MAKE) Xsccomp.heap Xmv + ${scc}: ${predef} sc-to-c: ${scc} ! Xsccomp sccomp: ${scc} ${sco} ${rt} ! ${CC} -o $@ ${CFLAGS} ${sco} ${rt} ${CLIBS} Xsccomp.heap: Xsccomp Xsccomp ../scrt/predef.sc ../scrt/objects.h ../scrt/libsc.a \ ../scrt/libsc_p.a ${cpu} Xsccomp.heap + sccomp.heap: sccomp + sccomp ../scrt/predef.sc ../scrt/objects.h ../scrt/libsc.a \ + ../scrt/libsc_p.a ${cpu} sccomp.heap Xmv: mv Xsccomp sccomp *************** *** 46,52 **** mv Xsccomp.heap sccomp.heap port: ! make "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo" \ Xsccomp.heap Xmv install-private: --- 52,58 ---- mv Xsccomp.heap sccomp.heap port: ! $(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo sccomp" \ Xsccomp.heap Xmv install-private: *************** *** 92,100 **** bindist: rdist -c sccomp makefile-tail makefile ${destdir} - - all: - make Xsccomp.heap Xmv srclinks: for x in ${scsc} ${scc} ${scsch}; \ --- 98,103 ---- *** 1.1 1991/10/23 18:50:45 --- test/makefile-tail 1991/10/23 21:30:55 *************** *** 46,72 **** ${sccomp} -schf ${sccomp}.heap -c ${CFLAGS} $*.c test: test.c test.o testchk.c testchk.o ${batch-c} ${batch-o} ! ${CC} -o test ${CFLAGS} test.o testchk.o ${batch-o} ${rt} -lm testn: testchk.c testchk.o ${rt} ! ${sccomp} -schf ${sccomp}.heap -i ${CFLAGS} -o test${n} test${n}.sc \ testchk.o ${rt} test50: test50.c test50.o ! ${CC} -o test50 ${CFLAGS} test50.o ${rt} -lm test51: test51.c test51.o ! ${CC} -o test51 ${CFLAGS} test51.o ${rt} -lm test52: test52.c test52.o ! ${CC} -o test52 ${CFLAGS} test52.o ${rt} -lm test53: test53.sc ! ${sccomp} -schf ${sccomp}.heap -i -o test53 ${CFLAGS} test53.sc \ ! ${rt} -lm test54: test54.c test54.o test54c.o testchk.o ! ${CC} -o test54 ${CFLAGS} test54.o test54c.o testchk.o ${rt} -lm port: --- 46,73 ---- ${sccomp} -schf ${sccomp}.heap -c ${CFLAGS} $*.c test: test.c test.o testchk.c testchk.o ${batch-c} ${batch-o} ! ${CC} -o test ${CFLAGS} test.o testchk.o ${batch-o} ${rt} ${CLIBS} testn: testchk.c testchk.o ${rt} ! ${sccomp} -schf ${sccomp}.heap -cc ${CC} -i ${CFLAGS} \ ! -o test${n} test${n}.sc \ testchk.o ${rt} test50: test50.c test50.o ! ${CC} -o test50 ${CFLAGS} test50.o ${rt} ${CLIBS} test51: test51.c test51.o ! ${CC} -o test51 ${CFLAGS} test51.o ${rt} ${CLIBS} test52: test52.c test52.o ! ${CC} -o test52 ${CFLAGS} test52.o ${rt} ${CLIBS} test53: test53.sc ! ${sccomp} -schf ${sccomp}.heap -cc ${CC} -i -o test53 ${CFLAGS} \ ! test53.sc ${rt} ${CLIBS} test54: test54.c test54.o test54c.o testchk.o ! ${CC} -o test54 ${CFLAGS} test54.o test54c.o testchk.o ${rt} ${CLIBS} port: *** 1.1 1991/10/23 18:51:57 --- xlib/makefile 1991/10/23 21:30:56 *************** *** 91,97 **** rm -f *.o scixl scxl.a hello puzzle clear all: ! make scixl scxl.a gensource: ! make ${xwssc} ${xwsc} --- 91,97 ---- rm -f *.o scixl scxl.a hello puzzle clear all: ! $(MAKE) scixl scxl.a gensource: ! $(MAKE) ${xwssc} ${xwsc} *** /dev/null Thu Oct 31 13:49:54 1991 --- xlib/xwss.sch Wed Oct 23 16:33:18 1991 *************** *** 0 **** --- 1,22 ---- + (define-external (YQUERYTREE dpy window) xwss) + (define-external (YGETATOMNAME dpy atom) xwss) + (define-external (YLISTPROPERTIES dpy window) xwss) + (define-external (YLISTFONTS dpy pattern maxnames) xwss) + (define-external (YLISTFONTSWITHINFO dpy pattern maxnames) xwss) + (define-external (YSETFONTPATH dpy directories) xwss) + (define-external (YGETFONTPATH dpy) xwss) + (define-external (YLISTINSTALLEDCOLORMAPS dpy window) xwss) + (define-external (FAMILY-ADDRESS->XHOSTADDRESS family address) xwss) + (define-external (YNEXTEVENT dpy event) xwss) + (define-external (YSELECT dpy . ports-time) xwss) + (define-external (YGETMOTIONEVENTS dpy window start stop) xwss) + (define-external (YSETSTANDARDPROPERTIES dpy window name icon_string icon_pixmap) xwss) + (define-external (YFETCHNAME dpy window) xwss) + (define-external (YGETICONNAME dpy window) xwss) + (define-external (YSETCOMMAND dpy window commands) xwss) + (define-external (YGETWMHINTS dpy window) xwss) + (define-external (YSETICONSIZES dpy window iconsizelist) xwss) + (define-external (YGETICONSIZES dpy window) xwss) + (define-external (YSETCLASSHINT dpy window name-class) xwss) + (define-external (YGETCLASSHINT dpy window) xwss) + (define-external (YLOOKUPSTRING event . opt) xwss)