summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore11
-rw-r--r--AUTHORS4
-rw-r--r--ChangeLog6
-rw-r--r--INSTALL318
-rw-r--r--Makefile.am6
-rw-r--r--NEWS0
-rw-r--r--README105
-rw-r--r--THANKS21
-rwxr-xr-xautogen.sh5
-rw-r--r--configure.ac30
-rw-r--r--elisp/Makefile.am34
-rw-r--r--elisp/geiser-autodoc.el146
-rw-r--r--elisp/geiser-base.el21
-rw-r--r--elisp/geiser-company.el121
-rw-r--r--elisp/geiser-completion.el19
-rw-r--r--elisp/geiser-connection.el12
-rw-r--r--elisp/geiser-debug.el63
-rw-r--r--elisp/geiser-doc.el31
-rw-r--r--elisp/geiser-edit.el73
-rw-r--r--elisp/geiser-eval.el50
-rw-r--r--elisp/geiser-guile.el41
-rw-r--r--elisp/geiser-impl.el138
-rw-r--r--elisp/geiser-install.el.in5
-rw-r--r--elisp/geiser-log.el2
-rw-r--r--elisp/geiser-mode.el11
-rw-r--r--elisp/geiser-plt.el42
-rw-r--r--elisp/geiser-reload.el95
-rw-r--r--elisp/geiser-repl.el36
-rw-r--r--elisp/geiser-syntax.el242
-rw-r--r--elisp/geiser-version.el.in12
-rw-r--r--elisp/geiser.el105
-rw-r--r--scheme/Makefile.am16
-rw-r--r--scheme/guile/geiser/completion.scm25
-rw-r--r--scheme/guile/geiser/doc.scm89
-rw-r--r--scheme/guile/geiser/emacs.scm3
-rw-r--r--scheme/guile/geiser/evaluation.scm64
-rw-r--r--scheme/guile/geiser/xref.scm9
-rw-r--r--scheme/plt/geiser/autodoc.ss101
-rw-r--r--scheme/plt/geiser/completions.ss27
-rw-r--r--scheme/plt/geiser/eval.ss45
40 files changed, 1508 insertions, 676 deletions
diff --git a/.gitignore b/.gitignore
index 106f9fe..c1eb482 100644
--- a/.gitignore
+++ b/.gitignore
@@ -2,3 +2,14 @@
/scheme/guile/geiser/eval.go
/scheme/guile/geiser/introspection.go
/scheme/guile/geiser/file.go
+/Makefile
+/Makefile.in
+/aclocal.m4
+/configure
+/elisp-comp
+/elisp/Makefile.in
+/install-sh
+/missing
+/scheme/Makefile.in
+/scheme/guile/Makefile.in
+/scheme/guile/geiser/Makefile.in
diff --git a/AUTHORS b/AUTHORS
new file mode 100644
index 0000000..c1ecdb8
--- /dev/null
+++ b/AUTHORS
@@ -0,0 +1,4 @@
+Jose A. Ortega Ruiz <jao@gnu.org> designed and implemented GNU Geiser. For
+more boring details about him, see <http://hacks-galore.org/jao>.
+
+See also the files THANKS and ChangeLog.
diff --git a/ChangeLog b/ChangeLog
new file mode 100644
index 0000000..09d790c
--- /dev/null
+++ b/ChangeLog
@@ -0,0 +1,6 @@
+## The contents of this file will be generated during 'make dist' by the
+## shell command:
+
+ git log --summary --stat
+
+# which you can run using 'sh ChangeLog'
diff --git a/INSTALL b/INSTALL
new file mode 100644
index 0000000..57d9c1f
--- /dev/null
+++ b/INSTALL
@@ -0,0 +1,318 @@
+Installing Geiser.
+------------------
+
+You'll find below the generic build and installation instructions for
+a GNU package, which Geiser happens to be. As you know, they can be
+summarised as:
+
+ mkdir build && cd build
+ ../configure
+ make
+ make install
+
+And, in our case, we'll need to tell emacs about this new little
+package with
+
+ (require 'geiser-install)
+
+in your moral equivalent to ~/.emacs.
+
+As explained in the README file, Geiser is also directly usable from
+its source tree, with no configuration whatsoever. Read that README to
+see how.
+
+As promised, here you have the gory details of the autotools jazz,
+which you can freely and safely skip on a first, second and third
+reading.
+
+Installation Instructions
+*************************
+
+Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002, 2004, 2005,
+2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+ This file is free documentation; the Free Software Foundation gives
+unlimited permission to copy, distribute and modify it.
+
+Basic Installation
+==================
+
+ Briefly, the shell commands `./configure; make; make install' should
+configure, build, and install this package. The following
+more-detailed instructions are generic; see the `README' file for
+instructions specific to this package.
+
+ The `configure' shell script attempts to guess correct values for
+various system-dependent variables used during compilation. It uses
+those values to create a `Makefile' in each directory of the package.
+It may also create one or more `.h' files containing system-dependent
+definitions. Finally, it creates a shell script `config.status' that
+you can run in the future to recreate the current configuration, and a
+file `config.log' containing compiler output (useful mainly for
+debugging `configure').
+
+ It can also use an optional file (typically called `config.cache'
+and enabled with `--cache-file=config.cache' or simply `-C') that saves
+the results of its tests to speed up reconfiguring. Caching is
+disabled by default to prevent problems with accidental use of stale
+cache files.
+
+ If you need to do unusual things to compile the package, please try
+to figure out how `configure' could check whether to do them, and mail
+diffs or instructions to the address given in the `README' so they can
+be considered for the next release. If you are using the cache, and at
+some point `config.cache' contains results you don't want to keep, you
+may remove or edit it.
+
+ The file `configure.ac' (or `configure.in') is used to create
+`configure' by a program called `autoconf'. You need `configure.ac' if
+you want to change it or regenerate `configure' using a newer version
+of `autoconf'.
+
+The simplest way to compile this package is:
+
+ 1. `cd' to the directory containing the package's source code and type
+ `./configure' to configure the package for your system.
+
+ Running `configure' might take a while. While running, it prints
+ some messages telling which features it is checking for.
+
+ 2. Type `make' to compile the package.
+
+ 3. Optionally, type `make check' to run any self-tests that come with
+ the package.
+
+ 4. Type `make install' to install the programs and any data files and
+ documentation.
+
+ 5. You can remove the program binaries and object files from the
+ source code directory by typing `make clean'. To also remove the
+ files that `configure' created (so you can compile the package for
+ a different kind of computer), type `make distclean'. There is
+ also a `make maintainer-clean' target, but that is intended mainly
+ for the package's developers. If you use it, you may have to get
+ all sorts of other programs in order to regenerate files that came
+ with the distribution.
+
+ 6. Often, you can also type `make uninstall' to remove the installed
+ files again.
+
+Compilers and Options
+=====================
+
+ Some systems require unusual options for compilation or linking that
+the `configure' script does not know about. Run `./configure --help'
+for details on some of the pertinent environment variables.
+
+ You can give `configure' initial values for configuration parameters
+by setting variables in the command line or in the environment. Here
+is an example:
+
+ ./configure CC=c99 CFLAGS=-g LIBS=-lposix
+
+ *Note Defining Variables::, for more details.
+
+Compiling For Multiple Architectures
+====================================
+
+ You can compile the package for more than one kind of computer at the
+same time, by placing the object files for each architecture in their
+own directory. To do this, you can use GNU `make'. `cd' to the
+directory where you want the object files and executables to go and run
+the `configure' script. `configure' automatically checks for the
+source code in the directory that `configure' is in and in `..'.
+
+ With a non-GNU `make', it is safer to compile the package for one
+architecture at a time in the source code directory. After you have
+installed the package for one architecture, use `make distclean' before
+reconfiguring for another architecture.
+
+ On MacOS X 10.5 and later systems, you can create libraries and
+executables that work on multiple system types--known as "fat" or
+"universal" binaries--by specifying multiple `-arch' options to the
+compiler but only a single `-arch' option to the preprocessor. Like
+this:
+
+ ./configure CC="gcc -arch i386 -arch x86_64 -arch ppc -arch ppc64" \
+ CXX="g++ -arch i386 -arch x86_64 -arch ppc -arch ppc64" \
+ CPP="gcc -E" CXXCPP="g++ -E"
+
+ This is not guaranteed to produce working output in all cases, you
+may have to build one architecture at a time and combine the results
+using the `lipo' tool if you have problems.
+
+Installation Names
+==================
+
+ By default, `make install' installs the package's commands under
+`/usr/local/bin', include files under `/usr/local/include', etc. You
+can specify an installation prefix other than `/usr/local' by giving
+`configure' the option `--prefix=PREFIX'.
+
+ You can specify separate installation prefixes for
+architecture-specific files and architecture-independent files. If you
+pass the option `--exec-prefix=PREFIX' to `configure', the package uses
+PREFIX as the prefix for installing programs and libraries.
+Documentation and other data files still use the regular prefix.
+
+ In addition, if you use an unusual directory layout you can give
+options like `--bindir=DIR' to specify different values for particular
+kinds of files. Run `configure --help' for a list of the directories
+you can set and what kinds of files go in them.
+
+ If the package supports it, you can cause programs to be installed
+with an extra prefix or suffix on their names by giving `configure' the
+option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'.
+
+Optional Features
+=================
+
+ Some packages pay attention to `--enable-FEATURE' options to
+`configure', where FEATURE indicates an optional part of the package.
+They may also pay attention to `--with-PACKAGE' options, where PACKAGE
+is something like `gnu-as' or `x' (for the X Window System). The
+`README' should mention any `--enable-' and `--with-' options that the
+package recognizes.
+
+ For packages that use the X Window System, `configure' can usually
+find the X include and library files automatically, but if it doesn't,
+you can use the `configure' options `--x-includes=DIR' and
+`--x-libraries=DIR' to specify their locations.
+
+Particular systems
+==================
+
+ On HP-UX, the default C compiler is not ANSI C compatible. If GNU
+CC is not installed, it is recommended to use the following options in
+order to use an ANSI C compiler:
+
+ ./configure CC="cc -Ae"
+
+and if that doesn't work, install pre-built binaries of GCC for HP-UX.
+
+ On OSF/1 a.k.a. Tru64, some versions of the default C compiler cannot
+parse its `<wchar.h>' header file. The option `-nodtk' can be used as
+a workaround. If GNU CC is not installed, it is therefore recommended
+to try
+
+ ./configure CC="cc"
+
+and if that doesn't work, try
+
+ ./configure CC="cc -nodtk"
+
+Specifying the System Type
+==========================
+
+ There may be some features `configure' cannot figure out
+automatically, but needs to determine by the type of machine the package
+will run on. Usually, assuming the package is built to be run on the
+_same_ architectures, `configure' can figure that out, but if it prints
+a message saying it cannot guess the machine type, give it the
+`--build=TYPE' option. TYPE can either be a short name for the system
+type, such as `sun4', or a canonical name which has the form:
+
+ CPU-COMPANY-SYSTEM
+
+where SYSTEM can have one of these forms:
+
+ OS KERNEL-OS
+
+ See the file `config.sub' for the possible values of each field. If
+`config.sub' isn't included in this package, then this package doesn't
+need to know the machine type.
+
+ If you are _building_ compiler tools for cross-compiling, you should
+use the option `--target=TYPE' to select the type of system they will
+produce code for.
+
+ If you want to _use_ a cross compiler, that generates code for a
+platform different from the build platform, you should specify the
+"host" platform (i.e., that on which the generated programs will
+eventually be run) with `--host=TYPE'.
+
+Sharing Defaults
+================
+
+ If you want to set default values for `configure' scripts to share,
+you can create a site shell script called `config.site' that gives
+default values for variables like `CC', `cache_file', and `prefix'.
+`configure' looks for `PREFIX/share/config.site' if it exists, then
+`PREFIX/etc/config.site' if it exists. Or, you can set the
+`CONFIG_SITE' environment variable to the location of the site script.
+A warning: not all `configure' scripts look for a site script.
+
+Defining Variables
+==================
+
+ Variables not defined in a site shell script can be set in the
+environment passed to `configure'. However, some packages may run
+configure again during the build, and the customized values of these
+variables may be lost. In order to avoid this problem, you should set
+them in the `configure' command line, using `VAR=value'. For example:
+
+ ./configure CC=/usr/local2/bin/gcc
+
+causes the specified `gcc' to be used as the C compiler (unless it is
+overridden in the site shell script).
+
+Unfortunately, this technique does not work for `CONFIG_SHELL' due to
+an Autoconf bug. Until the bug is fixed you can use this workaround:
+
+ CONFIG_SHELL=/bin/bash /bin/bash ./configure CONFIG_SHELL=/bin/bash
+
+`configure' Invocation
+======================
+
+ `configure' recognizes the following options to control how it
+operates.
+
+`--help'
+`-h'
+ Print a summary of all of the options to `configure', and exit.
+
+`--help=short'
+`--help=recursive'
+ Print a summary of the options unique to this package's
+ `configure', and exit. The `short' variant lists options used
+ only in the top level, while the `recursive' variant lists options
+ also present in any nested packages.
+
+`--version'
+`-V'
+ Print the version of Autoconf used to generate the `configure'
+ script, and exit.
+
+`--cache-file=FILE'
+ Enable the cache: use and save the results of the tests in FILE,
+ traditionally `config.cache'. FILE defaults to `/dev/null' to
+ disable caching.
+
+`--config-cache'
+`-C'
+ Alias for `--cache-file=config.cache'.
+
+`--quiet'
+`--silent'
+`-q'
+ Do not print messages saying which checks are being made. To
+ suppress all normal output, redirect it to `/dev/null' (any error
+ messages will still be shown).
+
+`--srcdir=DIR'
+ Look for the package's source code in directory DIR. Usually
+ `configure' can determine that directory automatically.
+
+`--prefix=DIR'
+ Use DIR as the installation prefix. *Note Installation Names::
+ for more details, including other options available for fine-tuning
+ the installation locations.
+
+`--no-create'
+`-n'
+ Run the configure checks, but stop before creating any output
+ files.
+
+`configure' also accepts some other, not widely useful, options. Run
+`configure --help' for more details.
+
diff --git a/Makefile.am b/Makefile.am
new file mode 100644
index 0000000..c86aecb
--- /dev/null
+++ b/Makefile.am
@@ -0,0 +1,6 @@
+SUBDIRS = . elisp scheme
+
+EXTRA_DIST = THANKS
+
+dist-hook:
+ $(SHELL) $(top_srcdir)/ChangeLog > $(top_distdir)/ChangeLog
diff --git a/NEWS b/NEWS
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/NEWS
diff --git a/README b/README
index 626bed9..8870006 100644
--- a/README
+++ b/README
@@ -22,35 +22,75 @@
Currently supported implementations are Guile and PLT.
- - Guile works only with the development, vm-based binary. Be sure
- to customize `geiser-repl-guile-binary' to point to a correct vm
- binary.
+ - Guile 1.9.x virtual machine required.
- PLT Scheme 4.1.5.5 or better required.
* Installation
+ Geiser can be used either directly from its uninstalled source tree
+ or byte-compiled and installed after perfoming the standard
+ configure/make/make install dance.
- - In your .emacs:
+*** In place
+ - Extract the tarball or clone the git repository anywhere in your
+ file system. Let's call that place <path-to-geiser>.
+ - In your .emacs:
- (load-file "<path-to-geiser>/elisp/geiser.el")
+ (load-file "<path-to-geiser>/elisp/geiser.el")
- This installs all supported Scheme implementations. You can list
- explicitly the ones that you want by setting the variable
- `geiser-impl-installed-implementations' *before* loading geiser.el.
- For instance:
+*** Byte-compiled
+ - Create a build directory, `build', say:
+ $ cd <path-to-geiser>
+ $ mkdir build; cd build
+ - Configure and make:
+ $ ../configure && make
+ You'll have a directory called "elisp" which contains Geiser's
+ elisp bytecode. Now, you can either use it in place, with the
+ .emacs incantation:
- (setq geiser-impl-installed-implementations '(plt guile))
+ (load-file "<path-to-geiser>/build/elisp/geiser.elc")
- On opening a scheme file, Geiser will try to guess its Scheme,
- defaulting to the first in the list.
+ or install it with:
- - Check the geiser customization group for some options with:
+ $ make install
+
+ and require 'geiser-install (not 'geiser, mind you) in your emacs
+ initialization file:
+
+ (require 'geiser-install)
+
+ You're ready to go!
+
+* Basic configuration
+ The loading invocations above install all supported Scheme
+ implementations. You can list explicitly the ones that you want by
+ setting the variable `geiser-impl-installed-implementations' *before*
+ loading geiser.el. For instance:
+
+ (setq geiser-impl-installed-implementations '(plt guile))
+
+ On opening a scheme file, Geiser will try to guess its Scheme,
+ defaulting to the first in the list. Use `C-c C-s' to select the
+ implementation by hand (on a per file basis).
+
+ Check the geiser customization group for some options with:
M-x customize-group RET geiser RET
- In particular, customize `geiser-repl-<impl>-binary' (in
- geiser-repl), which should point to an executable in your path.
+ In particular, customize `geiser-repl-<impl>-binary' (in
+ geiser-repl), which should point to an executable in your path.
+
+ To start a REPL, M-x geiser.
+
+*** Completion with company-mode
+ Geiser offers identifier and module name completion, bound to
+ M-TAB and M-` respectively. Only names visible in the current
+ module are offered.
- - To start a REPL, M-x geiser.
+ While that is cool and all, things are even better: if you have
+ [[http://nschum.de/src/emacs/company-mode/][company-mode]] installed, Geiser's completion will use it. Just
+ require company-mode and, from then on, any new scheme buffer or
+ REPL will use it. If you didn't know about Nikolaj Schumacher's
+ awesome mode, check [[http://www.screentoaster.com/watch/stU0lSRERIR1pYRFVdXVlRVFFV/company_mode_for_gnu_emacs][this screencast]].
* Quick key reference
@@ -94,22 +134,23 @@
*** In the REPL
- |----------------+-------------------------------------------|
- | C-c C-z, C-c z | Start Scheme REPL (if it's not running) |
- |----------------+-------------------------------------------|
- | M-. | Edit identifier at point |
- | TAB, M-TAB | Complete identifier at point |
- | M-`, C-. | Complete module name at point |
- |----------------+-------------------------------------------|
- | M-p, M-n | Prompt history, matching current prefix |
- |----------------+-------------------------------------------|
- | C-c k | Compile and load scheme file |
- | C-c l | Load scheme file |
- |----------------+-------------------------------------------|
- | C-c d | See documentation for identifier at point |
- | C-c m | See module documentation |
- | C-c a | Toggle autodoc mode |
- |----------------+-------------------------------------------|
+ |----------------+----------------------------------------------------|
+ | C-c C-z, C-c z | Start Scheme REPL (if it's not running) |
+ |----------------+----------------------------------------------------|
+ | M-. | Edit identifier at point |
+ | TAB, M-TAB | Complete identifier at point |
+ | M-`, C-. | Complete module name at point |
+ |----------------+----------------------------------------------------|
+ | M-p, M-n | Prompt history, matching current prefix |
+ |----------------+----------------------------------------------------|
+ | C-c C-k, C-c k | Nuke REPL: use it if the REPL becomes unresponsive |
+ |----------------+----------------------------------------------------|
+ | C-c l | Load scheme file |
+ |----------------+----------------------------------------------------|
+ | C-c d | See documentation for identifier at point |
+ | C-c m | See module documentation |
+ | C-c a | Toggle autodoc mode |
+ |----------------+----------------------------------------------------|
*** In the documentation browser:
diff --git a/THANKS b/THANKS
new file mode 100644
index 0000000..17d1c08
--- /dev/null
+++ b/THANKS
@@ -0,0 +1,21 @@
+
+Andy Wingo, Geiser's first user, has been a continuous source of
+encouragement and suggestions, and keeps improving Guile and heeding
+my feature requests.
+
+Eduardo Cavazos' contagious enthusiasm has helped in many ways to keep
+Geiser alive, and he's become its best evangelist in R6RS circles.
+
+Eli Barzilay took the time to play with an early beta and make many
+valuable suggestions, besides answering all my 'how do you in PLT'
+questions.
+
+Matthew Flatt, Robby Findler and the rest of the PLT team did not only
+answer my inquiries, but provided almost instant fixes to the few
+issues i found.
+
+Thanks also to the PLT and Guile communities, for showing me that
+Geiser was not only possible, but a pleasure to hack on.
+
+Karl Berry happily jeopardized GNU's prestige by reviewing and
+accepting Geiser as a GNU official package.
diff --git a/autogen.sh b/autogen.sh
new file mode 100755
index 0000000..781eabd
--- /dev/null
+++ b/autogen.sh
@@ -0,0 +1,5 @@
+#!/bin/sh
+
+[ -f elisp/geiser.el ] || exit 1
+
+autoreconf -Wall -i
diff --git a/configure.ac b/configure.ac
new file mode 100644
index 0000000..2333901
--- /dev/null
+++ b/configure.ac
@@ -0,0 +1,30 @@
+# Copyright (C) 2009 Free Software Foundation, Inc.
+#
+# This file is free software; as a special exception the author gives
+# unlimited permission to copy and/or distribute it, with or without
+# modifications, as long as this notice is preserved.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY, to the extent permitted by law; without even the
+# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+AC_INIT([GNU Geiser],[0.0.7],[jao@gnu.org],geiser)
+AC_CONFIG_SRCDIR([elisp/geiser.el])
+AM_INIT_AUTOMAKE
+
+AC_PROG_MAKE_SET
+AC_PROG_INSTALL
+AC_PROG_MKDIR_P
+AC_CHECK_PROG(MAKEINFO, makeinfo, makeinfo, no)
+AC_CHECK_PROG(TEXI2PDF, texi2pdf, texi2pdf, false)
+
+AM_PATH_LISPDIR
+
+AC_CONFIG_FILES([
+Makefile
+elisp/Makefile
+elisp/geiser-version.el
+scheme/Makefile
+])
+
+AC_OUTPUT
diff --git a/elisp/Makefile.am b/elisp/Makefile.am
new file mode 100644
index 0000000..9f93e64
--- /dev/null
+++ b/elisp/Makefile.am
@@ -0,0 +1,34 @@
+EXTRA_DIST = geiser-install.el.in
+
+dist_lisp_LISP = \
+ geiser-autodoc.el \
+ geiser-base.el \
+ geiser-company.el \
+ geiser-compile.el \
+ geiser-completion.el \
+ geiser-connection.el \
+ geiser-custom.el \
+ geiser-debug.el \
+ geiser-doc.el \
+ geiser-edit.el \
+ geiser.el \
+ geiser-eval.el \
+ geiser-guile.el \
+ geiser-impl.el \
+ geiser-log.el \
+ geiser-mode.el \
+ geiser-plt.el \
+ geiser-popup.el \
+ geiser-reload.el \
+ geiser-repl.el \
+ geiser-syntax.el \
+ geiser-xref.el \
+ geiser-version.el
+
+lisp_LISP = geiser-install.el
+
+CLEANFILES = geiser-install.el
+
+geiser-install.el: $(srcdir)/geiser.el $(srcdir)/geiser-install.el.in
+ @sed -e "s|@SCHEME_DIR[@]|$(datarootdir)/geiser|" $(srcdir)/geiser-install.el.in >$@
+
diff --git a/elisp/geiser-autodoc.el b/elisp/geiser-autodoc.el
index f6d36a8..75f2e7c 100644
--- a/elisp/geiser-autodoc.el
+++ b/elisp/geiser-autodoc.el
@@ -46,14 +46,6 @@
'font-lock-function-name-face
geiser-autodoc "highlighting procedure name in autodoc messages")
-(geiser-custom--defface autodoc-optional-arg-marker
- 'font-lock-keyword-face
- geiser-autodoc "highlighting #:opt marker in autodoc messages")
-
-(geiser-custom--defface autodoc-key-arg-marker
- 'font-lock-keyword-face
- geiser-autodoc "highlighting #:key marker in autodoc messages")
-
(defcustom geiser-autodoc-delay 0.3
"Delay before autodoc messages are fetched and displayed, in seconds."
:type 'number
@@ -74,79 +66,107 @@ when `geiser-autodoc-display-module-p' is on."
;;; Procedure arguments:
(make-variable-buffer-local
- (defvar geiser-autodoc--last nil))
-
-(make-variable-buffer-local
- (defvar geiser-autodoc--last-result nil))
-
-(defun geiser-autodoc--function-args (form)
- (if (equal (car geiser-autodoc--last) form) (cdr geiser-autodoc--last)
- (when form
- (let ((res (geiser-eval--send/result
- `(:eval ((:ge autodoc) (quote (:scm ,form))))
- 500)))
- (when (and res (listp res))
- (unless (equalp res geiser-autodoc--last-result)
- (setq geiser-autodoc--last-result res)
- (setq geiser-autodoc--last
- (cons form
- (geiser-autodoc--str (cdr (assoc 'signature res))
- (or (cdr (assoc 'position res)) 0)
- (cdr (assoc 'module res))))))
- (cdr geiser-autodoc--last))))))
-
-(defun geiser-autodoc--insert-arg (arg current pos)
- (let ((p (point))
- (str (format "%s" (if (eq arg '\#:rest) "." arg)))
- (face (cond ((eq '\#:opt arg)
- 'geiser-font-lock-autodoc-optional-arg-marker)
- ((eq '\#:key arg)
- 'geiser-font-lock-autodoc-key-arg-marker)
- ((= current pos)
- 'geiser-font-lock-autodoc-current-arg)
- (t nil))))
- (insert str)
- (when (listp arg)
- (save-excursion
- (replace-regexp "(quote \\(.*\\))" "'\\1" nil p (point))
- (replace-string "nil" "()" t p (point))))
- (when face (put-text-property p (point) 'face face))))
+ (defvar geiser-autodoc--cached-signatures nil))
+
+(defun geiser-autodoc--get-signatures (funs &optional keep-cached)
+ (when funs
+ (let ((fs (assq (car funs) geiser-autodoc--cached-signatures)))
+ (unless fs
+ (let ((missing) (cached))
+ (if (not geiser-autodoc--cached-signatures)
+ (setq missing funs)
+ (dolist (f funs)
+ (let ((cf (assq f geiser-autodoc--cached-signatures)))
+ (if cf (push cf cached)
+ (push f missing)))))
+ (unless (or cached keep-cached)
+ (setq geiser-autodoc--cached-signatures nil))
+ (when missing
+ (let ((res (geiser-eval--send/result `(:eval ((:ge autodoc)
+ (quote ,missing)))
+ 500)))
+ (when res
+ (setq geiser-autodoc--cached-signatures
+ (append res (if keep-cached
+ geiser-autodoc--cached-signatures
+ cached))))))))
+ geiser-autodoc--cached-signatures)))
+
+(defun geiser-autodoc--insert-args (args current &optional pos)
+ (dolist (a args)
+ (let ((p (point)))
+ (insert (format "%s" a))
+ (when (or (and (numberp pos)
+ (numberp current)
+ (setq current (1+ current))
+ (= (1+ pos) current))
+ (and (symbolp current)
+ (listp a)
+ (eq current (car a))))
+ (put-text-property p (point) 'face 'geiser-font-lock-autodoc-current-arg)
+ (setq pos nil current nil)))
+ (insert " "))
+ (when args (backward-char))
+ current)
(defsubst geiser-autodoc--proc-name (proc module)
(let ((str (if module
(format geiser-autodoc-procedure-name-format module proc)
proc)))
- (put-text-property 0 (length str)
- 'face 'geiser-font-lock-autodoc-procedure-name
- str)
- str))
-
-(defun geiser-autodoc--str (signature pos module)
- (when (consp signature)
- (let* ((proc (car signature))
- (args (cdr signature))
- (len (if (listp args) (length args) 0))
- (current 1)
- (pos (if (> pos len) len pos)))
- (if (eq args 'variable)
- (geiser-autodoc--proc-name proc module)
+ (propertize str 'face 'geiser-font-lock-autodoc-procedure-name)))
+
+(defun geiser-autodoc--str (desc signature)
+ (let ((proc (car desc))
+ (args (cdr (assoc 'args signature)))
+ (module (cdr (assoc 'module signature))))
+ (if (not args) (geiser-autodoc--proc-name proc module)
+ (let ((cpos 1)
+ (pos (or (cadr desc) 0))
+ (prev (caddr desc))
+ (reqs (cdr (assoc 'required args)))
+ (opts (cdr (assoc 'optional args)))
+ (keys (cdr (assoc 'key args))))
(save-current-buffer
(set-buffer (geiser-syntax--font-lock-buffer))
(erase-buffer)
(insert (format "(%s" (geiser-autodoc--proc-name proc module)))
- (dolist (a args)
+ (when reqs
(insert " ")
- (geiser-autodoc--insert-arg a current pos)
- (setq current (1+ current)))
+ (setq cpos
+ (geiser-autodoc--insert-args reqs
+ cpos
+ (and (not (zerop pos)) pos))))
+ (when opts
+ (insert " [")
+ (setq cpos (geiser-autodoc--insert-args opts cpos pos))
+ (when keys
+ (insert " [")
+ (geiser-autodoc--insert-args keys prev nil)
+ (insert "]"))
+ (insert "]"))
(insert ")")
(buffer-string))))))
+(defun geiser-autodoc--autodoc (path &optional keep-cached)
+ (let ((signs (geiser-autodoc--get-signatures (mapcar 'car path) keep-cached))
+ (p (car path))
+ (s))
+ (while (and path (not s))
+ (unless (setq s (cdr (assq (car p) signs)))
+ (setq p (car path))
+ (setq path (cdr path))))
+ (when s (geiser-autodoc--str p s))))
+
;;; Autodoc function:
+(make-variable-buffer-local
+ (defvar geiser-autodoc--inhibit-flag nil))
+
(defun geiser-autodoc--eldoc-function ()
(condition-case e
- (geiser-autodoc--function-args (geiser-syntax--get-partial-sexp))
+ (and (not geiser-autodoc--inhibit-flag)
+ (geiser-autodoc--autodoc (geiser-syntax--scan-sexps)))
(error (format "Autodoc not available (%s)" (error-message-string e)))))
diff --git a/elisp/geiser-base.el b/elisp/geiser-base.el
index 362930d..fca955a 100644
--- a/elisp/geiser-base.el
+++ b/elisp/geiser-base.el
@@ -25,26 +25,10 @@
;;; Code:
-
-;;; Versioning:
-
-(defconst geiser-version-major 0
- "Geiser's major version number.")
-(defconst geiser-version-minor 1
- "Geiser's minor version number.")
-
-(defun geiser-version-string ()
- "Geiser's version as a string."
- (format "%s.%s" geiser-version-major geiser-version-minor))
-
-(defun geiser-version ()
- "Echoes Geiser's version."
- (interactive)
- (message "Geiser %s" (geiser-version-string)))
-
-
;;; Emacs compatibility:
+(require 'cl)
+
(eval-after-load "ring"
'(when (not (fboundp 'ring-member))
(defun ring-member (ring item)
@@ -55,7 +39,6 @@
(when (not (fboundp 'completion-table-dynamic))
(defun completion-table-dynamic (fun)
- (require 'cl)
(lexical-let ((fun fun))
(lambda (string pred action)
(with-current-buffer (let ((win (minibuffer-selected-window)))
diff --git a/elisp/geiser-company.el b/elisp/geiser-company.el
new file mode 100644
index 0000000..37c2196
--- /dev/null
+++ b/elisp/geiser-company.el
@@ -0,0 +1,121 @@
+;; geiser-company.el -- integration with company-mode
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Mon Aug 24, 2009 12:44
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'geiser-autodoc)
+(require 'geiser-completion)
+(require 'geiser-edit)
+(require 'geiser-base)
+
+
+;;; Helpers:
+
+(make-variable-buffer-local
+ (defvar geiser-company--enabled-flag nil))
+
+(make-variable-buffer-local
+ (defvar geiser-company--autodoc-flag nil))
+
+(defsubst geiser-company--candidates (prefix module)
+ (car (geiser-completion--complete prefix module)))
+
+(defsubst geiser-company--doc (id module)
+ (ignore-errors
+ (if module
+ (format "%s [module]" id)
+ (or (geiser-autodoc--autodoc (list (list (intern id) 0)) t)
+ (format "%s [local id]" id)))))
+
+(defsubst geiser-company--doc-buffer (id module)
+ nil)
+
+(defun geiser-company--location (id module)
+ (ignore-errors
+ (let ((id (intern id)))
+ (save-excursion
+ (if module
+ (geiser-edit-module id 'noselect)
+ (geiser-edit-symbol id 'noselect))))))
+
+(defun geiser-company--prefix-at-point (module)
+ (when geiser-company--enabled-flag
+ (cond ((nth 8 (syntax-ppss)) 'stop)
+ ((looking-at-p "\\_>") (geiser-completion--prefix module))
+ (module 'stop)
+ (t nil))))
+
+
+;;; Activation
+
+(defun geiser-company--setup (enable)
+ (setq geiser-company--enabled-flag enable)
+ (when (fboundp 'geiser-company--setup-company)
+ (geiser-company--setup-company enable)))
+
+(defun geiser-company--inhibit-autodoc (ignored)
+ (when (setq geiser-company--autodoc-flag geiser-autodoc-mode)
+ (geiser-autodoc-mode -1)))
+
+(defun geiser-company--restore-autodoc (&optional ignored)
+ (when geiser-company--autodoc-flag
+ (geiser-autodoc-mode 1)))
+
+
+;;; Backends:
+(defmacro geiser-company--make-backend (name mod)
+ `(defun ,name (command &optional arg &rest ignored)
+ "A `company-mode' completion back-end for `geiser-mode'."
+ (interactive (list 'interactive))
+ (case command
+ ('interactive (company-begin-backend ',name))
+ ('prefix (geiser-company--prefix-at-point ,mod))
+ ('candidates (geiser-company--candidates arg ,mod))
+ ('meta (geiser-company--doc arg ,mod))
+ ('doc-buffer (geiser-company--doc-buffer arg ,mod))
+ ('location (geiser-company--location arg ,mod))
+ ('sorted t))))
+
+(defvar geiser-company--backend '(company-geiser-ids company-geiser-modules))
+
+(eval-after-load "company"
+ '(progn
+ (defun geiser-company--setup-company (enable)
+ (set (make-local-variable 'company-default-lighter) "/C")
+ (set (make-local-variable 'company-echo-delay) 0.01)
+ (company-mode nil)
+ (when enable (company-mode enable)))
+ (geiser-company--make-backend company-geiser-ids nil)
+ (geiser-company--make-backend company-geiser-modules t)
+ (add-to-list 'company-backends geiser-company--backend)
+ (add-hook 'company-completion-finished-hook 'geiser-company--restore-autodoc)
+ (add-hook 'company-completion-cancelled-hook 'geiser-company--restore-autodoc)
+ (add-hook 'company-completion-started-hook 'geiser-company--inhibit-autodoc)))
+
+
+;;; Reload support:
+
+(defun geiser-company-unload-function ()
+ (when (boundp 'company-backends)
+ (setq company-backends (remove geiser-company--backend company-backends))))
+
+
+(provide 'geiser-company)
+;;; geiser-company.el ends here
diff --git a/elisp/geiser-completion.el b/elisp/geiser-completion.el
index 799280e..e3bd74b 100644
--- a/elisp/geiser-completion.el
+++ b/elisp/geiser-completion.el
@@ -29,7 +29,7 @@
(require 'geiser-syntax)
(require 'geiser-base)
-(eval-when-compile (require 'cl))
+(require 'cl)
;;; Completions window handling, heavily inspired in slime's:
@@ -84,7 +84,7 @@ terminates a current completion."
(remove-hook 'pre-command-hook
'geiser-completion--maybe-restore-window-cfg)
(condition-case err
- (cond ((find last-command-char "()\"'`,# \r\n:")
+ (cond ((find last-command-event "()\"'`,# \r\n:")
(geiser-completion--restore-window-cfg))
((not (geiser-completion--window-active-p))
(geiser-completion--forget-window-cfg))
@@ -146,11 +146,10 @@ terminates a current completion."
;;; Completion functionality:
-(defsubst geiser-completion--symbol-list (prefix)
+(defun geiser-completion--symbol-list (prefix)
(delete-duplicates
- (geiser-eval--send/result
- `(:eval ((:ge completions) ,prefix
- (quote (:scm ,(or (geiser-syntax--get-partial-sexp) "()"))))))
+ (append (mapcar (lambda (s) (format "%s" s)) (geiser-syntax--locals-around-point))
+ (geiser-eval--send/result `(:eval ((:ge completions) ,prefix))))
:test 'string=))
(defsubst geiser-completion--module-list (prefix)
@@ -205,14 +204,16 @@ terminates a current completion."
(funcall geiser-completion--symbol-begin-function module))
(save-excursion (skip-syntax-backward "^-()>") (point))))
+(defsubst geiser-completion--prefix (module)
+ (buffer-substring-no-properties (point)
+ (geiser-completion--symbol-begin module)))
+
(defun geiser-completion--complete-symbol (&optional arg)
"Complete the symbol at point.
Perform completion similar to Emacs' complete-symbol.
With prefix, complete module name."
(interactive "P")
- (let* ((end (point))
- (beg (geiser-completion--symbol-begin arg))
- (prefix (buffer-substring-no-properties beg end))
+ (let* ((prefix (geiser-completion--prefix arg))
(result (geiser-completion--complete prefix arg))
(completions (car result))
(partial (cdr result)))
diff --git a/elisp/geiser-connection.el b/elisp/geiser-connection.el
index 33579f6..4f8592b 100644
--- a/elisp/geiser-connection.el
+++ b/elisp/geiser-connection.el
@@ -160,11 +160,15 @@
(defun geiser-con--comint-buffer-form ()
(with-current-buffer (geiser-con--comint-buffer)
- (geiser-syntax--prepare-scheme-for-elisp-reader)
(condition-case nil
- (let ((form (read (current-buffer))))
- (if (listp form) form (error)))
- (error `((error (key . geiser-con-error) (msg . ,(buffer-string))))))))
+ (progn
+ (goto-char (point-min))
+ (re-search-forward "((\\(result\\|error\\)\\>")
+ (goto-char (match-beginning 0))
+ (let ((form (read (current-buffer))))
+ (if (listp form) form (error))))
+ (error `((error (key . geiser-con-error))
+ (output . ,(buffer-string)))))))
(defun geiser-con--process-next (con)
(when (not (geiser-con--connection-current-request con))
diff --git a/elisp/geiser-debug.el b/elisp/geiser-debug.el
index 7ebd0b5..6d795df 100644
--- a/elisp/geiser-debug.el
+++ b/elisp/geiser-debug.el
@@ -25,6 +25,7 @@
;;; Code:
+(require 'geiser-impl)
(require 'geiser-eval)
(require 'geiser-popup)
(require 'geiser-base)
@@ -32,15 +33,23 @@
;;; Debug buffer mode:
-(defconst geiser-debug--error-alist
- '(("^\\(In file +\\| +\\)\\([^ \n]+\\):\\([0-9]+\\):\\([0-9]+\\)" 2 3 4)
- ("^Error.+$" nil nil nil 0)))
+(defvar geiser-debug-mode-map
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (set-keymap-parent map button-buffer-map)
+ map))
-(define-derived-mode geiser-debug-mode compilation-mode "Geiser Dbg"
+(defun geiser-debug-mode ()
"A major mode for displaying Scheme compilation and evaluation results.
\\{geiser-debug-mode-map}"
- (set (make-local-variable 'compilation-error-regexp-alist)
- geiser-debug--error-alist))
+ (interactive)
+ (kill-all-local-variables)
+ (buffer-disable-undo)
+ (use-local-map geiser-debug-mode-map)
+ (set-syntax-table scheme-mode-syntax-table)
+ (setq mode-name "Geiser DBG")
+ (setq major-mode 'geiser-debug-mode)
+ (setq buffer-read-only t))
;;; Buffer for displaying evaluation results:
@@ -50,42 +59,25 @@
;;; Displaying retorts
-(defun geiser-debug--display-retort (what ret)
+(defun geiser-debug--display-retort (what ret &optional res)
(let* ((err (geiser-eval--retort-error ret))
+ (key (geiser-eval--error-key err))
(output (geiser-eval--retort-output ret))
- (stack (geiser-eval--retort-stack ret)))
+ (impl geiser-impl--implementation)
+ (module (geiser-eval--get-module)))
(geiser-debug--with-buffer
(erase-buffer)
(insert what)
(newline 2)
- (when err (insert (geiser-eval--error-str err) "\n\n"))
- (when output (insert output "\n\n"))
- (when stack (geiser-debug--display-stack stack))
+ (when res
+ (insert res)
+ (newline 2))
+ (unless (geiser-impl--display-error impl module key output)
+ (when err (insert (geiser-eval--error-str err) "\n\n"))
+ (when output (insert output "\n\n")))
(goto-char (point-min)))
(when err (geiser-debug--pop-to-buffer))))
-(defsubst geiser-debug--frame-proc (frame) (cdr (assoc 'procedure frame)))
-(defsubst geiser-debug--frame-desc (frame) (cdr (assoc 'description frame)))
-(defsubst geiser-debug--frame-source (frame) (cdr (assoc 'source frame)))
-(defsubst geiser-debug--frame-source-file (src) (car src))
-(defsubst geiser-debug--frame-source-line (src) (or (cadr src) 1))
-(defsubst geiser-debug--frame-source-column (src) (or (caddr src) 0))
-
-(defun geiser-debug--display-stack (stack)
- (mapc 'geiser-debug--display-stack-frame (reverse (cdr stack))))
-
-(defun geiser-debug--display-stack-frame (frame)
- (let ((procedure (geiser-debug--frame-proc frame))
- (source (geiser-debug--frame-source frame))
- (description (geiser-debug--frame-desc frame)))
- (if source
- (insert (format "In file %s:%s:%s\n"
- (geiser-debug--frame-source-file source)
- (geiser-debug--frame-source-line source)
- (1+ (geiser-debug--frame-source-column source))))
- (insert "In expression:\n"))
- (insert (format "%s\n" description))))
-
(defsubst geiser-debug--wrap-region (str)
(format "(begin %s)" str))
@@ -99,10 +91,11 @@
(wrapped (if wrap (geiser-debug--wrap-region str) str))
(code `(,(if compile :comp :eval) (:scm ,wrapped)))
(ret (geiser-eval--send/wait code))
+ (res (geiser-eval--retort-result-str ret))
(err (geiser-eval--retort-error ret)))
(when and-go (funcall and-go))
- (when (not err) (message (format "=> %s" (geiser-eval--retort-result ret))))
- (geiser-debug--display-retort str ret)))
+ (when (not err) (message "%s" res))
+ (geiser-debug--display-retort str ret res)))
(defun geiser-debug--expand-region (start end all wrap)
(let* ((str (buffer-substring-no-properties start end))
diff --git a/elisp/geiser-doc.el b/elisp/geiser-doc.el
index 8024239..29f0de2 100644
--- a/elisp/geiser-doc.el
+++ b/elisp/geiser-doc.el
@@ -24,7 +24,9 @@
;;; Code:
+(require 'geiser-impl)
(require 'geiser-completion)
+(require 'geiser-autodoc)
(require 'geiser-eval)
(require 'geiser-syntax)
(require 'geiser-popup)
@@ -157,32 +159,27 @@
;;; Commands:
-(make-variable-buffer-local
- (defvar geiser-doc--external-help-function nil))
-
-(defun geiser-doc--external-help (symbol module)
- (and geiser-doc--external-help-function
- (funcall geiser-doc--external-help-function symbol module)))
-
(defun geiser-doc--get-docstring (symbol module)
- (geiser-eval--send/result `(:eval ((:ge symbol-documentation) ',symbol) ,module)))
+ (geiser-eval--send/result
+ `(:eval ((:ge symbol-documentation) ',symbol) ,module)))
(defun geiser-doc--get-module-exports (module)
(geiser-eval--send/result `(:eval ((:ge module-exports) (:module ,module)))))
(defun geiser-doc-symbol (symbol &optional module impl)
- (let ((module (or module (geiser-eval--get-module))))
- (unless (geiser-doc--external-help symbol module)
- (let ((impl (or impl geiser-impl--implementation))
- (ds (geiser-doc--get-docstring symbol module)))
+ (let ((module (or module (geiser-eval--get-module)))
+ (impl (or impl geiser-impl--implementation)))
+ (unless (geiser-impl--external-help impl symbol module)
+ (let ((ds (geiser-doc--get-docstring symbol module)))
(if (or (not ds) (not (listp ds)))
(message "No documentation available for '%s'" symbol)
(geiser-doc--with-buffer
(erase-buffer)
- (geiser-doc--insert-title (cdr (assoc 'signature ds)))
+ (geiser-doc--insert-title (geiser-autodoc--str (list (format "%s" symbol) 0)
+ (cdr (assoc 'signature ds))))
(newline)
(insert (or (cdr (assoc 'docstring ds)) ""))
- (goto-line (point-min))
+ (goto-char (point-min))
(setq geiser-doc--buffer-link
(geiser-doc--history-push
(geiser-doc--make-link symbol module impl))))
@@ -193,7 +190,8 @@
With prefix argument, ask for symbol (with completion)."
(interactive "P")
(let ((symbol (or (and (not arg) (symbol-at-point))
- (geiser-completion--read-symbol "Symbol: " (symbol-at-point)))))
+ (geiser-completion--read-symbol "Symbol: "
+ (symbol-at-point)))))
(when symbol (geiser-doc-symbol symbol))))
@@ -219,7 +217,8 @@ With prefix argument, ask for symbol (with completion)."
impl))
(goto-char (point-min))
(setq geiser-doc--buffer-link
- (geiser-doc--history-push (geiser-doc--make-link nil module impl))))
+ (geiser-doc--history-push
+ (geiser-doc--make-link nil module impl))))
(geiser-doc--pop-to-buffer))))
(defun geiser-doc-next (&optional forget-current)
diff --git a/elisp/geiser-edit.el b/elisp/geiser-edit.el
index 986099e..0ec1669 100644
--- a/elisp/geiser-edit.el
+++ b/elisp/geiser-edit.el
@@ -44,7 +44,11 @@
(geiser-edit--define-custom-visit
geiser-edit-symbol-method geiser-mode
- "How the new buffer is opened when invoking \\[geiser-edit-symbol-at-point].")
+ "How the new buffer is opened when invoking \\[geiser-edit-symbol-at-point]
+or following links in error buffers.")
+
+(geiser-custom--defface error-link
+ 'link geiser-debug "links in error buffers")
;;; Auxiliar functions:
@@ -52,6 +56,7 @@
(defun geiser-edit--visit-file (file method)
(cond ((eq method 'window) (find-file-other-window file))
((eq method 'frame) (find-file-other-frame file))
+ ((eq method 'noselect) (find-file-noselect file t))
(t (find-file file))))
(defsubst geiser-edit--location-name (loc)
@@ -60,8 +65,18 @@
(defsubst geiser-edit--location-file (loc)
(cdr (assoc 'file loc)))
+(defsubst geiser-edit--to-number (x)
+ (cond ((numberp x) x)
+ ((stringp x) (string-to-number x))))
+
(defsubst geiser-edit--location-line (loc)
- (cdr (assoc 'line loc)))
+ (geiser-edit--to-number (cdr (assoc 'line loc))))
+
+(defsubst geiser-edit--location-column (loc)
+ (geiser-edit--to-number (cdr (assoc 'column loc))))
+
+(defsubst geiser-edit--make-location (name file line column)
+ `((name . ,name) (file . ,file) (line . ,line) (column . ,column)))
(defconst geiser-edit--def-re
(regexp-opt '("define"
@@ -92,8 +107,9 @@
(format "\\_<%s\\_>" (regexp-quote (format "%s" thing))))
(defun geiser-edit--goto-line (symbol line)
+ (goto-char (point-min))
(if (numberp line)
- (goto-line line)
+ (forward-line (max 0 (1- line)))
(goto-char (point-min))
(when (or (re-search-forward (geiser-edit--def-re symbol) nil t)
(re-search-forward (geiser-edit--def-re* symbol) nil t)
@@ -103,26 +119,51 @@
(defun geiser-edit--try-edit-location (symbol loc &optional method)
(let ((symbol (or (geiser-edit--location-name loc) symbol))
(file (geiser-edit--location-file loc))
- (line (geiser-edit--location-line loc)))
+ (line (geiser-edit--location-line loc))
+ (col (geiser-edit--location-column loc)))
(unless file (error "Couldn't find edit location for '%s'" symbol))
(unless (file-readable-p file) (error "Couldn't open '%s' for read" file))
(geiser-edit--visit-file file (or method geiser-edit-symbol-method))
- (geiser-edit--goto-line symbol line)))
+ (geiser-edit--goto-line symbol line)
+ (when col
+ (beginning-of-line)
+ (forward-char col))
+ (cons (current-buffer) (point))))
-(defsubst geiser-edit--try-edit (symbol ret)
- (geiser-edit--try-edit-location symbol (geiser-eval--retort-result ret)))
+(defsubst geiser-edit--try-edit (symbol ret &optional method)
+ (geiser-edit--try-edit-location symbol (geiser-eval--retort-result ret) method))
+
+
+;;; Links
+
+(define-button-type 'geiser-edit--button
+ 'action 'geiser-edit--button-action
+ 'face 'geiser-font-lock-error-link
+ 'follow-link t)
+
+(defun geiser-edit--button-action (button)
+ (let ((loc (button-get button 'geiser-location)))
+ (when loc (geiser-edit--try-edit-location nil loc))))
+
+(defun geiser-edit--make-link (beg end file line col)
+ (make-button beg end
+ :type 'geiser-edit--button
+ 'geiser-location
+ (geiser-edit--make-location 'error file line col)
+ 'help-echo "Go to error location"))
;;; Commands:
-(defun geiser-edit-symbol ()
+(defvar geiser-edit--symbol-history nil)
+
+(defun geiser-edit-symbol (symbol &optional method)
"Asks for a symbol to edit, with completion."
- (interactive)
- (let* ((symbol (geiser-completion--read-symbol "Edit symbol: "
- nil
- geiser-edit--symbol-history))
- (cmd `(:eval ((:ge symbol-location) ',symbol))))
- (geiser-edit--try-edit symbol (geiser-eval--send/wait cmd))))
+ (interactive (list (geiser-completion--read-symbol "Edit symbol: "
+ nil
+ geiser-edit--symbol-history)))
+ (let ((cmd `(:eval ((:ge symbol-location) ',symbol))))
+ (geiser-edit--try-edit symbol (geiser-eval--send/wait cmd) method)))
(defun geiser-edit-symbol-at-point (&optional arg)
"Opens a new window visiting the definition of the symbol at point.
@@ -142,11 +183,11 @@ With prefix, asks for the symbol to edit."
(pop-tag-mark)
(error "No previous location for find symbol invocation")))
-(defun geiser-edit-module (module)
+(defun geiser-edit-module (module &optional method)
"Asks for a module and opens it in a new buffer."
(interactive (list (geiser-completion--read-module)))
(let ((cmd `(:eval ((:ge module-location) (:module ,module)))))
- (geiser-edit--try-edit module (geiser-eval--send/wait cmd))))
+ (geiser-edit--try-edit module (geiser-eval--send/wait cmd) method)))
(provide 'geiser-edit)
diff --git a/elisp/geiser-eval.el b/elisp/geiser-eval.el
index c493092..1c8cbfe 100644
--- a/elisp/geiser-eval.el
+++ b/elisp/geiser-eval.el
@@ -54,25 +54,6 @@ EVAL, COMPILE, LOAD-FILE and COMPILE-FILE should be supported."))
;;; Code formatting:
-(defun geiser-eval--scheme-str (code)
- (cond ((null code) "'()")
- ((eq code :f) "#f")
- ((eq code :t) "#t")
- ((listp code)
- (cond ((eq (car code) :eval) (geiser-eval--eval (cdr code)))
- ((eq (car code) :comp) (geiser-eval--comp (cdr code)))
- ((eq (car code) :load-file)
- (geiser-eval--load-file (cadr code)))
- ((eq (car code) :comp-file)
- (geiser-eval--comp-file (cadr code)))
- ((eq (car code) :module) (geiser-eval--module (cadr code)))
- ((eq (car code) :ge) (geiser-eval--ge (cadr code)))
- ((eq (car code) :scm) (cadr code))
- (t (concat "("
- (mapconcat 'geiser-eval--scheme-str code " ") ")"))))
- ((symbolp code) (format "%s" code))
- (t (format "%S" code))))
-
(defsubst geiser-eval--eval (code)
(geiser-eval--scheme-str
`(,(geiser-eval--form 'eval) (quote ,(nth 0 code))
@@ -99,6 +80,25 @@ EVAL, COMPILE, LOAD-FILE and COMPILE-FILE should be supported."))
(defsubst geiser-eval--ge (proc)
(geiser-eval--scheme-str (geiser-eval--form proc)))
+(defun geiser-eval--scheme-str (code)
+ (cond ((null code) "'()")
+ ((eq code :f) "#f")
+ ((eq code :t) "#t")
+ ((listp code)
+ (cond ((eq (car code) :eval) (geiser-eval--eval (cdr code)))
+ ((eq (car code) :comp) (geiser-eval--comp (cdr code)))
+ ((eq (car code) :load-file)
+ (geiser-eval--load-file (cadr code)))
+ ((eq (car code) :comp-file)
+ (geiser-eval--comp-file (cadr code)))
+ ((eq (car code) :module) (geiser-eval--module (cadr code)))
+ ((eq (car code) :ge) (geiser-eval--ge (cadr code)))
+ ((eq (car code) :scm) (cadr code))
+ (t (concat "("
+ (mapconcat 'geiser-eval--scheme-str code " ") ")"))))
+ ((symbolp code) (format "%s" code))
+ (t (format "%S" code))))
+
;;; Code sending:
@@ -145,11 +145,17 @@ EVAL, COMPILE, LOAD-FILE and COMPILE-FILE should be supported."))
(defun geiser-eval--retort-result (ret)
(let ((values (cdr (assoc 'result ret))))
- (if (> (length values) 1) (cons :values values) (car values))))
+ (and (stringp (car values))
+ (ignore-errors (car (read-from-string (car values)))))))
+
+(defun geiser-eval--retort-result-str (ret)
+ (let ((values (cdr (assoc 'result ret))))
+ (if values
+ (concat "=> " (mapconcat 'identity values "\n=> "))
+ "(No value)")))
(defsubst geiser-eval--retort-output (ret) (cdr (assoc 'output ret)))
(defsubst geiser-eval--retort-error (ret) (cdr (assoc 'error ret)))
-(defsubst geiser-eval--retort-stack (ret) (cdr (assoc 'stack ret)))
(defsubst geiser-eval--error-key (err) (cdr (assoc 'key err)))
(defsubst geiser-eval--error-subr (err) (cdr (assoc 'subr err)))
@@ -160,7 +166,7 @@ EVAL, COMPILE, LOAD-FILE and COMPILE-FILE should be supported."))
(let* ((key (geiser-eval--error-key err))
(key-str (if key (format ": %s" key) ":"))
(subr (geiser-eval--error-subr err))
- (subr-str (if subr (format " (%s):" subr) ":"))
+ (subr-str (if subr (format " (%s):" subr) ""))
(msg (geiser-eval--error-msg err))
(msg-str (if msg (format "\n %s" msg) ""))
(rest (geiser-eval--error-rest err))
diff --git a/elisp/geiser-guile.el b/elisp/geiser-guile.el
index 44a4e9f..ed14e87 100644
--- a/elisp/geiser-guile.el
+++ b/elisp/geiser-guile.el
@@ -27,6 +27,9 @@
(require 'geiser-syntax)
(require 'geiser-custom)
(require 'geiser-base)
+(require 'geiser-eval)
+(require 'geiser-edit)
+(require 'geiser)
;;; Customization:
@@ -121,6 +124,44 @@ This function uses `geiser-guile-init-file' if it exists."
(save-excursion (skip-syntax-backward "^-()>") (point))))
+;;; Error display
+(defvar geiser-guile--file-cache (make-hash-table :test 'equal))
+
+(defun geiser-guile--resolve-file (file)
+ (when (and (stringp file) (not (string-equal file "unknown file")))
+ (if (file-name-absolute-p file) file
+ (or (gethash file geiser-guile--file-cache)
+ (puthash file
+ (geiser-eval--send/result `(:eval ((:ge find-file) ,file)))
+ geiser-guile--file-cache)))))
+
+(defconst geiser-guile--file-rx
+ "^In \\([^\n:]+\\):\n *\\([[:digit:]]+\\|\\?\\):")
+
+(defun geiser-guile--find-files ()
+ (save-excursion
+ (while (re-search-forward geiser-guile--file-rx nil t)
+ (let ((file (match-string 1))
+ (beg (match-beginning 1))
+ (end (match-end 1))
+ (line (string-to-number (or (match-string 2) "0"))))
+ (let ((file (geiser-guile--resolve-file file)))
+ (when file
+ (geiser-edit--make-link beg end file line 0)))))))
+
+(defun geiser-guile-display-error (module key msg)
+ (when key
+ (insert "Error: ")
+ (geiser--insert-with-face (format "%s" key) 'bold)
+ (newline 2))
+ (when msg
+ (let ((p (point)))
+ (insert msg)
+ (goto-char p)
+ (geiser-guile--find-files)))
+ t)
+
+
;;; Trying to ascertain whether a buffer is Guile Scheme:
(defun geiser-guile-guess ()
diff --git a/elisp/geiser-impl.el b/elisp/geiser-impl.el
index 6bc4e79..00fa1ef 100644
--- a/elisp/geiser-impl.el
+++ b/elisp/geiser-impl.el
@@ -27,7 +27,6 @@
(require 'geiser-eval)
(require 'geiser-base)
-(require 'geiser-doc)
(require 'geiser-completion)
@@ -47,16 +46,63 @@
:type '(repeat symbol)
:group 'geiser-impl)
+(defcustom geiser-impl-implementations-alist nil
+ "A map from regular expressions or directories to implementations.
+When opening a new file, its full path will be matched against
+each one of the regular expressions or directories in this map in order to
+determine its scheme flavour."
+ :type '(repeat (list (choice (group :tag "Regular expression"
+ (const regexp) regexp)
+ (group :tag "Directory"
+ (const dir) directory))
+ symbol))
+ :group 'geiser-impl)
+
+
+;;; Auxiliary functions:
+(defsubst geiser-impl--sym (imp name)
+ (intern (format "geiser-%s-%s" imp name)))
+
+(defsubst geiser-impl--boundp (imp name)
+ (boundp (geiser-impl--sym imp name)))
+
+(defsubst geiser-impl--fboundp (imp name)
+ (fboundp (geiser-impl--sym imp name)))
+
+(defsubst geiser-impl--impl-feature (impl)
+ (intern (format "geiser-%s" impl)))
+
+(defun geiser-impl--value (imp name &optional fun)
+ (let ((sym (geiser-impl--sym imp name)))
+ (unless (or (and (not fun) (boundp sym))
+ (and fun (fboundp sym)))
+ (error "Unbound %s '%s' in Geiser Scheme implementation %s"
+ (if fun "function" "variable") sym imp))
+ (if fun (symbol-function sym) (symbol-value sym))))
+
+(defsubst geiser-impl--call-if-bound (imp name &rest args)
+ (when (geiser-impl--fboundp imp name)
+ (apply (geiser-impl--value imp name t) args)))
+
;;; Registering implementations:
(defvar geiser-impl--impls nil)
+(make-variable-buffer-local
+ (defvar geiser-impl--implementation nil))
+
(defun geiser-impl--register (impl)
- (add-to-list 'geiser-impl--impls impl))
+ (when (and (not (memq impl geiser-impl--impls))
+ (require (geiser-impl--impl-feature impl) nil t))
+ (add-to-list 'geiser-impl--impls impl)))
(defun geiser-impl--unregister (impl)
- (setq geiser-impl--impls (remove impl geiser-impl--impls)))
+ (setq geiser-impl--impls (remove impl geiser-impl--impls))
+ (ignore-errors (unload-feature (geiser-impl--impl-feature impl))))
+
+(defun geiser-impl--add-to-alist (kind what impl)
+ (add-to-list 'geiser-impl-implementations-alist (list (list kind what) impl)))
(defvar geiser-impl--default-implementation
geiser-impl-default-implementation)
@@ -74,9 +120,6 @@
;;; Installing Scheme implementations:
-(make-variable-buffer-local
- (defvar geiser-impl--implementation nil))
-
(defvar geiser-impl--impl-prompt-history nil)
(defun geiser-impl--read-impl (&optional prompt impls non-req)
@@ -97,37 +140,12 @@
(geiser-impl--install-vars impl)
(geiser-impl--register impl)))
-(defsubst geiser-impl--sym (imp name)
- (intern (format "geiser-%s-%s" imp name)))
-
-(defsubst geiser-impl--boundp (imp name)
- (boundp (geiser-impl--sym imp name)))
-
-(defsubst geiser-impl--fboundp (imp name)
- (fboundp (geiser-impl--sym imp name)))
-
-(defun geiser-impl--value (imp name &optional fun)
- (let ((sym (geiser-impl--sym imp name)))
- (unless (or (and (not fun) (boundp sym))
- (and fun (fboundp sym)))
- (error "Unbound %s '%s' in Geiser Scheme implementation %s"
- (if fun "function" "variable") sym imp))
- (if fun (symbol-function sym) (symbol-value sym))))
-
-(defsubst geiser-impl--call-if-bound (imp name &rest args)
- (when (geiser-impl--fboundp imp name)
- (apply (geiser-impl--value imp name t) args)))
-
(defsubst geiser-impl--module-function (impl)
(geiser-impl--sym impl "get-module"))
(defsubst geiser-impl--geiser-procedure-function (impl)
(geiser-impl--sym impl "geiser-procedure"))
-(defsubst geiser-impl--external-help-function (impl)
- (let ((f (geiser-impl--sym impl "external-help")))
- (and (fboundp f) f)))
-
(defsubst geiser-impl--symbol-begin (impl)
(geiser-impl--sym impl "symbol-begin"))
@@ -136,8 +154,6 @@
(geiser-impl--module-function impl))
(setq geiser-eval--geiser-procedure-function
(geiser-impl--geiser-procedure-function impl))
- (setq geiser-doc--external-help-function
- (geiser-impl--external-help-function impl))
(setq geiser-completion--symbol-begin-function
(geiser-impl--symbol-begin impl)))
@@ -150,8 +166,6 @@
(geiser-impl--module-function imp))
(geiser-eval--geiser-procedure-function
(geiser-impl--geiser-procedure-function imp))
- (geiser-doc--external-help-function
- (geiser-impl--external-help-function imp))
(geiser-completion--symbol-begin-function
(geiser-impl--symbol-begin imp)))
(funcall thunk)))
@@ -171,7 +185,8 @@
(geiser-impl--call-if-bound (geiser-impl--default-implementation)
"geiser-procedure"
proc))
-(set-default 'geiser-eval--geiser-procedure-function 'geiser-impl-geiser-procedure)
+(set-default 'geiser-eval--geiser-procedure-function
+ 'geiser-impl-geiser-procedure)
;;; Access to implementation specific execution parameters:
@@ -191,6 +206,12 @@
(defsubst geiser-impl--startup (impl)
(geiser-impl--call-if-bound impl "startup"))
+(defsubst geiser-impl--external-help (impl symbol module)
+ (geiser-impl--call-if-bound impl "external-help" symbol module))
+
+(defsubst geiser-impl--display-error (impl module key msg)
+ (geiser-impl--call-if-bound impl "display-error" module key msg))
+
;;; Access to implementation guessing function:
@@ -199,22 +220,58 @@
"Set this buffer local variable to specify the Scheme
implementation to be used by Geiser."))
+(defun geiser-impl--match-impl (desc bn)
+ (let ((rx (if (eq (car desc) 'regexp)
+ (cadr desc)
+ (format "^%s" (regexp-quote (cadr desc))))))
+ (and rx (string-match-p rx bn))))
+
(defun geiser-impl--guess ()
(or geiser-impl--implementation
geiser-scheme-implementation
(catch 'impl
+ (let ((bn (buffer-file-name)))
+ (when bn
+ (dolist (x geiser-impl-implementations-alist)
+ (when (geiser-impl--match-impl (car x) bn)
+ (throw 'impl (cadr x))))))
(dolist (impl geiser-impl--impls)
(when (geiser-impl--call-if-bound impl "guess")
(throw 'impl impl))))
(geiser-impl--default-implementation)))
+;;; User commands
+
+(defun geiser-register-implementation ()
+ "Register a new Scheme implementation."
+ (interactive)
+ (let ((current geiser-impl-installed-implementations)
+ (impl (geiser-impl--read-impl "New Scheme implementation: " nil t)))
+ (unless (geiser-impl--register impl)
+ (error "geiser-%s.el not found in load-path" impl))
+ (when (and (not (memq impl current))
+ (y-or-n-p "Remember this implementation using customize? "))
+ (customize-save-variable
+ 'geiser-impl-installed-implementations (cons impl current)))))
+
+(defun geiser-unregister-implementation ()
+ "Unregister an installed Scheme implementation."
+ (interactive)
+ (let* ((current geiser-impl-installed-implementations)
+ (impl (geiser-impl--read-impl "Forget implementation: " current)))
+ (geiser-impl--unregister impl)
+ (when (and impl
+ (y-or-n-p "Forget permanently using customize? "))
+ (customize-save-variable
+ 'geiser-impl-installed-implementations (remove impl current)))))
+
+
;;; Unload support
(defun geiser-impl-unload-function ()
(dolist (imp (mapcar 'geiser-impl--impl-feature geiser-impl--impls))
- (when (featurep imp) (unload-feature imp)))
- t)
+ (when (featurep imp) (unload-feature imp t))))
(defun geiser-impl--reload-implementations (impls)
(dolist (impl impls)
@@ -223,8 +280,11 @@ implementation to be used by Geiser."))
;;; Initialization:
-(mapc 'geiser-impl--register geiser-impl-installed-implementations)
+(eval-after-load 'geiser-impl
+ '(mapc 'geiser-impl--register
+ (or geiser-impl-installed-implementations '(guile plt))))
(provide 'geiser-impl)
+
;;; geiser-impl.el ends here
diff --git a/elisp/geiser-install.el.in b/elisp/geiser-install.el.in
new file mode 100644
index 0000000..da9f28f
--- /dev/null
+++ b/elisp/geiser-install.el.in
@@ -0,0 +1,5 @@
+(require 'geiser)
+
+(setq geiser-scheme-dir "@SCHEME_DIR@")
+
+(provide 'geiser-install)
diff --git a/elisp/geiser-log.el b/elisp/geiser-log.el
index 68e0fae..27a485a 100644
--- a/elisp/geiser-log.el
+++ b/elisp/geiser-log.el
@@ -28,6 +28,8 @@
(require 'geiser-popup)
(require 'geiser-base)
+(require 'comint)
+
;;; Customization:
diff --git a/elisp/geiser-mode.el b/elisp/geiser-mode.el
index e19cb68..fa686ec 100644
--- a/elisp/geiser-mode.el
+++ b/elisp/geiser-mode.el
@@ -28,6 +28,7 @@
(require 'geiser-doc)
(require 'geiser-compile)
(require 'geiser-completion)
+(require 'geiser-company)
(require 'geiser-xref)
(require 'geiser-edit)
(require 'geiser-autodoc)
@@ -52,6 +53,11 @@
:group 'geiser-autodoc
:type 'boolean)
+(defcustom geiser-mode-company-p t
+ "Whether to use company-mode for completion, if available."
+ :group 'geiser-mode
+ :type 'boolean)
+
(defcustom geiser-mode-smart-tab-p nil
"Whether `geiser-smart-tab-mode' gets enabled by default in Scheme buffers."
:group 'geiser-mode
@@ -188,6 +194,7 @@ interacting with the Geiser REPL is at your disposal.
(when geiser-mode (geiser-impl--set-buffer-implementation))
(setq geiser-autodoc-mode-string "/A")
(setq geiser-smart-tab-mode-string "/T")
+ (geiser-company--setup (and geiser-mode geiser-mode-company-p))
(when geiser-mode-autodoc-p (geiser-autodoc-mode geiser-mode))
(when geiser-mode-smart-tab-p (geiser-smart-tab-mode geiser-mode)))
@@ -261,6 +268,10 @@ interacting with the Geiser REPL is at your disposal.
(geiser-mode 1)
(when (cdr b) (geiser-impl--set-buffer-implementation (cdr b))))))
+(defun geiser-mode-unload-function ()
+ (dolist (b (geiser-mode--buffers))
+ (with-current-buffer (car b) (geiser-mode nil))))
+
(provide 'geiser-mode)
;;; geiser-mode.el ends here
diff --git a/elisp/geiser-plt.el b/elisp/geiser-plt.el
index 44312b9..8810250 100644
--- a/elisp/geiser-plt.el
+++ b/elisp/geiser-plt.el
@@ -24,6 +24,8 @@
;;; Code:
+(require 'geiser-edit)
+(require 'geiser-doc)
(require 'geiser-eval)
(require 'geiser-syntax)
(require 'geiser-custom)
@@ -109,7 +111,7 @@ This function uses `geiser-plt-init-file' if it exists."
:f)))
(defun geiser-plt-get-module (&optional module)
- (cond ((and (null module) (geiser-plt--explicit-module)))
+ (cond ((and (null module) (buffer-file-name))) ;; (geiser-plt--explicit-module)
((null module) (geiser-plt--implicit-module))
((symbolp module) module)
((and (stringp module) (file-name-absolute-p module)) module)
@@ -121,13 +123,47 @@ This function uses `geiser-plt-init-file' if it exists."
;;; External help
+
(defun geiser-plt-external-help (symbol module)
(message "Requesting help for '%s'..." symbol)
- (geiser-eval--send/wait `(:eval (get-help ',symbol (:module ,module)) geiser/autodoc))
+ (geiser-eval--send/wait
+ `(:eval (get-help ',symbol (:module ,module)) geiser/autodoc))
(minibuffer-message "%s done" (current-message))
t)
+;;; Error display
+
+(defconst geiser-plt--file-rxs '("^\\([^:\n\"]+\\):\\([0-9]+\\):\\([0-9]+\\)"
+ "path:\"?\\([^>\"\n]+\\)\"?>"
+ "module: \"\\([^>\"\n]+\\)\""))
+
+(defun geiser-plt--find-files (rx)
+ (save-excursion
+ (while (re-search-forward rx nil t)
+ (geiser-edit--make-link (match-beginning 1)
+ (match-end 1)
+ (match-string 1)
+ (match-string 2)
+ (match-string 3)))))
+
+(defun geiser-plt-display-error (module key msg)
+ (when key
+ (insert "Error: ")
+ (geiser-doc--insert-button key nil 'plt)
+ (newline 2))
+ (when msg
+ (let ((p (point)))
+ (insert msg)
+ (let ((end (point)))
+ (goto-char p)
+ (mapc 'geiser-plt--find-files geiser-plt--file-rxs)
+ (goto-char end)
+ (fill-region p end)
+ (newline))))
+ t)
+
+
;;; Trying to ascertain whether a buffer is mzscheme scheme:
(defun geiser-plt-guess ()
@@ -135,7 +171,7 @@ This function uses `geiser-plt-init-file' if it exists."
(goto-char (point-min))
(re-search-forward "#lang " nil t))
(geiser-plt--explicit-module)
- (string-equal (file-name-extension (buffer-file-name)) "ss")))
+ (string-equal (file-name-extension (or (buffer-file-name) "")) "ss")))
(provide 'geiser-plt)
diff --git a/elisp/geiser-reload.el b/elisp/geiser-reload.el
new file mode 100644
index 0000000..5a30e1f
--- /dev/null
+++ b/elisp/geiser-reload.el
@@ -0,0 +1,95 @@
+;; geiser-reload.el -- unload/load geiser packages
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Sat Aug 22, 2009 23:04
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'geiser-impl)
+(require 'geiser-repl)
+(require 'geiser-mode)
+(require 'geiser-base)
+(require 'geiser)
+
+
+;;; Reload:
+
+(defmacro geiser--features-list ()
+ (quote '(
+ geiser-mode
+ geiser-repl
+ geiser-xref
+ geiser-edit
+ geiser-doc
+ geiser-debug
+ geiser-impl
+ geiser-company
+ geiser-completion
+ geiser-autodoc
+ geiser-compile
+ geiser-eval
+ geiser-connection
+ geiser-syntax
+ geiser-log
+ geiser-custom
+ geiser-base
+ geiser-popup
+ geiser-install
+ geiser
+ geiser-version
+ )))
+
+(defun geiser-unload ()
+ "Unload all Geiser modules."
+ (interactive)
+ (let ((fs (geiser--features-list)))
+ (unload-feature 'geiser-reload t)
+ (dolist (f fs)
+ (when (featurep f) (unload-feature f t)))))
+
+(defun geiser-reload (&optional arg)
+ "Reload Geiser.
+With prefix arg, prompts for the DIRECTORY from which Geiser should be
+loaded again."
+ (interactive "P")
+ (let* ((old-dir geiser-elisp-dir)
+ (dir (or (and arg (read-directory-name "New Geiser elisp dir: "
+ old-dir old-dir t old-dir))
+ old-dir)))
+ (unless (or (file-exists-p (expand-file-name "geiser-reload.el" dir))
+ (file-exists-p (expand-file-name "geiser-reload.elc" dir)))
+ (error "%s does not contain Geiser!" dir))
+ (let ((installed (featurep 'geiser-install))
+ (installed-impls geiser-impl-installed-implementations)
+ (impls geiser-impl--impls)
+ (repls (geiser-repl--repl-list))
+ (buffers (geiser-mode--buffers)))
+ (geiser-unload)
+ (setq load-path (remove old-dir load-path))
+ (add-to-list 'load-path dir)
+ (setq geiser-impl-installed-implementations installed-impls)
+ (require 'geiser-reload)
+ (when installed (require 'geiser-install nil t))
+ (geiser-impl--reload-implementations impls)
+ (geiser-repl--restore repls)
+ (geiser-mode--restore buffers)
+ (message "Geiser reloaded!"))))
+
+
+(provide 'geiser-reload)
+;;; geiser-reload.el ends here
diff --git a/elisp/geiser-repl.el b/elisp/geiser-repl.el
index f4d85dc..4ea1bb7 100644
--- a/elisp/geiser-repl.el
+++ b/elisp/geiser-repl.el
@@ -24,6 +24,7 @@
;;; Code:
+(require 'geiser-company)
(require 'geiser-autodoc)
(require 'geiser-edit)
(require 'geiser-impl)
@@ -70,6 +71,11 @@ implementation name gets appended to it."
:type 'boolean
:group 'geiser-repl)
+(defcustom geiser-repl-company-p t
+ "Whether to use company-mode for completion, if available."
+ :group 'geiser-mode
+ :type 'boolean)
+
(defcustom geiser-repl-read-only-prompt-p t
"Whether the REPL's prompt should be read-only."
:type 'boolean
@@ -141,8 +147,8 @@ implementation name gets appended to it."
(geiser-repl--history-setup)
(geiser-con--setup-connection (current-buffer) prompt-rx)
(add-to-list 'geiser-repl--repls (current-buffer))
- (geiser-impl--startup impl)
- (geiser-repl--set-this-buffer-repl (current-buffer))))
+ (geiser-repl--set-this-buffer-repl (current-buffer))
+ (geiser-impl--startup impl)))
(defun geiser-repl--process ()
(let ((buffer (geiser-repl--get-repl geiser-impl--implementation)))
@@ -152,8 +158,10 @@ implementation name gets appended to it."
(setq geiser-eval--default-proc-function 'geiser-repl--process)
(defun geiser-repl--wait-for-prompt (timeout)
- (let ((p (point)) (seen))
- (while (and (not seen) (> timeout 0))
+ (let ((p (point)) (seen) (buffer (current-buffer)))
+ (while (and (not seen)
+ (> timeout 0)
+ (get-buffer-process buffer))
(sleep-for 0.1)
(setq timeout (- timeout 100))
(goto-char p)
@@ -176,7 +184,8 @@ implementation name gets appended to it."
(interactive
(list (or (geiser-repl--only-impl-p)
(and (eq major-mode 'geiser-repl-mode) geiser-impl--implementation)
- (geiser-repl--read-impl "Start Geiser for scheme implementation: "))))
+ (geiser-repl--read-impl
+ "Start Geiser for scheme implementation: "))))
(geiser-repl--start-repl impl))
(defun switch-to-geiser (&optional ask impl)
@@ -254,7 +263,8 @@ If no REPL is running, execute `run-geiser' to start a fresh one."
(set (make-local-variable 'comint-input-filter) 'geiser-repl--input-filter)
(add-hook 'kill-buffer-hook 'geiser-repl--on-kill nil t)
(comint-read-input-ring t)
- (set-process-sentinel (get-buffer-process (current-buffer)) 'geiser-repl--sentinel))
+ (set-process-sentinel (get-buffer-process (current-buffer))
+ 'geiser-repl--sentinel))
;;; geiser-repl mode:
@@ -288,18 +298,22 @@ If no REPL is running, execute `run-geiser' to start a fresh one."
'geiser-repl--beginning-of-defun)
(set-syntax-table scheme-mode-syntax-table)
(setq geiser-eval--get-module-function 'geiser-repl--module-function)
- (when geiser-repl-autodoc-p (geiser-autodoc-mode 1)))
+ (when geiser-repl-autodoc-p (geiser-autodoc-mode 1))
+ (geiser-company--setup geiser-repl-company-p)
+ (compilation-shell-minor-mode 1))
(define-key geiser-repl-mode-map "\C-d" 'delete-char)
-(define-key geiser-repl-mode-map "\C-cz" 'run-geiser)
-(define-key geiser-repl-mode-map "\C-c\C-z" 'run-geiser)
+(define-key geiser-repl-mode-map "\C-ck" 'geiser-repl-nuke)
+(define-key geiser-repl-mode-map "\C-c\C-k" 'geiser-repl-nuke)
+
+(define-key geiser-repl-mode-map "\C-cz" 'switch-to-geiser)
+(define-key geiser-repl-mode-map "\C-c\C-z" 'switch-to-geiser)
(define-key geiser-repl-mode-map "\C-a" 'geiser-repl--bol)
(define-key geiser-repl-mode-map (kbd "<home>") 'geiser-repl--bol)
(define-key geiser-repl-mode-map "\C-ca" 'geiser-autodoc-mode)
(define-key geiser-repl-mode-map "\C-cd" 'geiser-doc-symbol-at-point)
(define-key geiser-repl-mode-map "\C-cm" 'geiser-repl--doc-module)
-(define-key geiser-repl-mode-map "\C-ck" 'geiser-compile-file)
(define-key geiser-repl-mode-map "\C-cl" 'geiser-load-file)
(define-key geiser-repl-mode-map "\M-p" 'comint-previous-matching-input-from-input)
@@ -326,7 +340,7 @@ If no REPL is running, execute `run-geiser' to start a fresh one."
(defun geiser-repl--restore (impls)
(dolist (impl impls)
- (when impl (geiser impl))))
+ (when impl (geiser nil impl))))
(defun geiser-repl-unload-function ()
(dolist (repl geiser-repl--repls)
diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el
index 14d996c..ca218c8 100644
--- a/elisp/geiser-syntax.el
+++ b/elisp/geiser-syntax.el
@@ -80,87 +80,183 @@
(with-syntax 1))
+;;; A simple scheme reader
+
+(defvar geiser-syntax--read/buffer-limit nil)
+
+(defsubst geiser-syntax--read/eos ()
+ (or (eobp)
+ (and geiser-syntax--read/buffer-limit
+ (<= geiser-syntax--read/buffer-limit (point)))))
+
+(defsubst geiser-syntax--read/next-char ()
+ (unless (geiser-syntax--read/eos)
+ (forward-char)
+ (char-after)))
+
+(defsubst geiser-syntax--read/token (token)
+ (geiser-syntax--read/next-char)
+ (if (listp token) token (list token)))
+
+(defsubst geiser-syntax--read/elisp ()
+ (ignore-errors (read (current-buffer))))
+
+(defun geiser-syntax--read/matching (open close)
+ (let ((count 1)
+ (p (1+ (point))))
+ (while (and (> count 0)
+ (geiser-syntax--read/next-char))
+ (cond ((looking-at-p open) (setq count (1+ count)))
+ ((looking-at-p close) (setq count (1- count)))))
+ (buffer-substring-no-properties p (point))))
+
+(defsubst geiser-syntax--read/unprintable ()
+ (geiser-syntax--read/token
+ (cons 'unprintable (geiser-syntax--read/matching "<" ">"))))
+
+(defun geiser-syntax--read/skip-comment ()
+ (while (and (geiser-syntax--read/next-char)
+ (nth 8 (syntax-ppss))))
+ (geiser-syntax--read/next-token))
+
+(defun geiser-syntax--read/next-token ()
+ (skip-syntax-forward "->")
+ (if (geiser-syntax--read/eos) '(eob)
+ (case (char-after)
+ (?\; (geiser-syntax--read/skip-comment))
+ ((?\( ?\[) (geiser-syntax--read/token 'lparen))
+ ((?\) ?\]) (geiser-syntax--read/token 'rparen))
+ (?. (if (memq (syntax-after (1+ (point))) '(0 11 12))
+ (geiser-syntax--read/token 'dot)
+ (cons 'atom (geiser-syntax--read/elisp))))
+ (?\# (case (geiser-syntax--read/next-char)
+ ('nil '(eob))
+ (?| (geiser-syntax--read/skip-comment))
+ (?: (if (geiser-syntax--read/next-char)
+ (cons 'kwd (geiser-syntax--read/elisp))
+ '(eob)))
+ (?\\ (cons 'char (geiser-syntax--read/elisp)))
+ (?\( (geiser-syntax--read/token 'vectorb))
+ (?\< (geiser-syntax--read/unprintable))
+ (t (let ((tok (geiser-syntax--read/elisp)))
+ (if tok (cons 'atom (intern (format "#%s" tok)))
+ (geiser-syntax--read/next-token))))))
+ (?\' (geiser-syntax--read/token '(quote . quote)))
+ (?\` (geiser-syntax--read/token
+ `(backquote . ,backquote-backquote-symbol)))
+ (?, (if (eq (geiser-syntax--read/next-char) ?@)
+ (geiser-syntax--read/token
+ `(splice . ,backquote-splice-symbol))
+ `(unquote . ,backquote-unquote-symbol)))
+ (?\" (cons 'string (geiser-syntax--read/elisp)))
+ (t (cons 'atom (geiser-syntax--read/elisp))))))
+
+(defsubst geiser-syntax--read/match (&rest tks)
+ (let ((token (geiser-syntax--read/next-token)))
+ (if (memq (car token) tks) token
+ (error "Unexpected token: %s" token))))
+
+(defsubst geiser-syntax--read/try (&rest tks)
+ (let ((p (point))
+ (tk (ignore-errors (apply 'geiser-syntax--read/match tks))))
+ (unless tk (goto-char p))
+ tk))
+
+(defun geiser-syntax--read/list ()
+ (cond ((geiser-syntax--read/try 'dot)
+ (let ((tail (geiser-syntax--read)))
+ (geiser-syntax--read/match 'eob 'rparen)
+ tail))
+ ((geiser-syntax--read/try 'rparen 'eob) nil)
+ (t (cons (geiser-syntax--read)
+ (geiser-syntax--read/list)))))
+
+(defun geiser-syntax--read ()
+ (let ((token (geiser-syntax--read/next-token)))
+ (case (car token)
+ (eob nil)
+ (lparen (geiser-syntax--read/list))
+ (vectorb (apply 'vector (geiser-syntax--read/list)))
+ ((quote backquote unquote splice) (list (cdr token)
+ (geiser-syntax--read)))
+ (kwd `(:keyword . ,(cdr token)))
+ (unprintable (format "#<%s>" (cdr token)))
+ ((char string atom) (cdr token))
+ (t (error "Reading scheme syntax: unexpected token: %s" token)))))
+
+(defsubst geiser-syntax--read/keyword-value (s)
+ (and (consp s) (eq (car s) :keyword) (cdr s)))
+
+(defsubst geiser-syntax--form-after-point (&optional boundary)
+ (let ((geiser-syntax--read/buffer-limit (and (numberp boundary) boundary)))
+ (save-excursion (values (geiser-syntax--read) (point)))))
+
+
;;; Code parsing:
-(geiser-popup--define syntax " *geiser syntax analyst*" scheme-mode)
+(defsubst geiser-syntax--skip-comment/string ()
+ (goto-char (or (nth 8 (syntax-ppss)) (point))))
-(defun geiser-syntax--prepare-scheme-for-elisp-reader ()
- (let ((end (save-excursion
- (goto-char (point-max))
- (and (re-search-backward "(output \\. \"" nil t)
- (point)))))
- (goto-char (point-min))
- (while (re-search-forward "#\<\\([^>]*?\\)\>" end t)
- (let ((from (match-beginning 1))
- (to (match-end 1)))
- (goto-char from)
- (while (re-search-forward "\\([ ;'`]\\)" to t)
- (replace-match "\\\\\\1"))
- (goto-char from)
- (while (re-search-forward "[()]" to t)
- (replace-match ""))
- (goto-char to)))
- (goto-char (point-min))
- (while (re-search-forward "#(" end t) (replace-match "(vector "))
- (goto-char (point-min))
- (while (re-search-forward "#" end t) (replace-match "\\\\#"))
- (goto-char (point-min))
- (skip-syntax-forward "^(")))
-
-(defsubst geiser-syntax--del-sexp (arg)
- (let ((p (point)))
- (forward-sexp arg)
- (delete-region p (point))))
-
-(defconst geiser-syntax--placeholder (format "___%s___" (random 100)))
-
-(defsubst geiser-syntax--beginning-of-form ()
- (memq (char-after (point)) '(?\" ?\()))
-
-(defun geiser-syntax--complete-partial-sexp (buffer begin end)
- (geiser-syntax--with-buffer
- (erase-buffer)
- (insert-buffer-substring-no-properties buffer begin end)
- (when (not (geiser-syntax--beginning-of-form))
- (skip-syntax-backward "-<>")
- (delete-region (point) (point-max)))
- (let ((p (nth 8 (syntax-ppss))))
- (when p ;; inside a comment or string
- (delete-region p (point-max))
- (insert geiser-syntax--placeholder)))
- (when (cond ((eq (char-after (1- (point))) ?\))
- (geiser-syntax--del-sexp -1) t)
- ((geiser-syntax--beginning-of-form)
- (delete-region (point) (point-max)) t)
- ((memq (char-after (1- (point))) (list ?. ?@ ?, ?\' ?\` ?\# ?\\))
- (skip-syntax-backward "^-(")
- (delete-region (point) (point-max))
- t))
- (insert geiser-syntax--placeholder))
+(defsubst geiser-syntax--nesting-level ()
+ (or (nth 0 (syntax-ppss)) 0))
+
+(defun geiser-syntax--scan-sexps ()
+ (save-excursion
+ (let* ((fst (symbol-at-point))
+ (path (and fst (list (list fst 0)))))
+ (while (not (zerop (geiser-syntax--nesting-level)))
+ (let ((boundary (1+ (point))))
+ (backward-up-list)
+ (let ((form
+ (nth-value 0 (geiser-syntax--form-after-point boundary))))
+ (when (and (listp form) (car form) (symbolp (car form)))
+ (let* ((len-1 (1- (length form)))
+ (prev (and (> len-1 1) (nth (1- len-1) form)))
+ (prev (and prev
+ (geiser-syntax--read/keyword-value prev))))
+ (push `(,(car form)
+ ,len-1 ,@(and prev (symbolp prev) (list prev)))
+ path))))))
+ (nreverse path))))
+
+(defun geiser-syntax--scan-locals (form partial locals)
+ (flet ((if-symbol (x) (and (symbolp x) x))
+ (if-list (x) (and (listp x) x))
+ (normalize (vars) (mapcar (lambda (i) (if (listp i) (car i) i)) vars)))
+ (cond ((or (null form) (not (listp form))) (normalize locals))
+ ((not (memq (car form) '(define let let* letrec lambda)))
+ (geiser-syntax--scan-locals (car (last form)) partial locals))
+ (t
+ (let* ((head (car form))
+ (name (if-symbol (cadr form)))
+ (names (if name (if-list (caddr form))
+ (if-list (cadr form))))
+ (rest (if name (cdddr form) (cddr form)))
+ (use-names (or (eq head 'let*) (not partial) rest)))
+ (when name (push name locals))
+ (when use-names (dolist (n names) (push n locals)))
+ (dolist (f (butlast rest))
+ (when (eq (car f) 'define) (push (cadr f) locals)))
+ (geiser-syntax--scan-locals (car (last (or rest names)))
+ partial
+ locals))))))
+
+(defun geiser-syntax--locals-around-point ()
+ (when (eq major-mode 'scheme-mode)
(save-excursion
- (goto-char (point-min))
- (while (re-search-forward "[.@,'`#\\\\]" nil t)
- (replace-match "" nil nil))
- (goto-char (point-min))
- (while (re-search-forward "\\[" nil t)
- (replace-match "(" nil nil))
- (goto-char (point-min))
- (while (re-search-forward "\\]" nil t)
- (replace-match ")" nil nil)))
- (let ((depth (nth 0 (parse-partial-sexp (point-min) (point)))))
- (unless (zerop depth) (insert (make-string depth ?\)))))
- (when (< (point-min) (point)) (buffer-substring (point-min) (point)))))
-
-(defsubst geiser-syntax--get-partial-sexp ()
- (unless (zerop (nth 0 (syntax-ppss)))
- (let* ((end (if (geiser-syntax--beginning-of-form) (1+ (point))
- (save-excursion (skip-syntax-forward "^-\"<>()") (point))))
- (begin (save-excursion (beginning-of-defun) (point))))
- (geiser-syntax--complete-partial-sexp (current-buffer) begin end))))
+ (geiser-syntax--skip-comment/string)
+ (let ((boundary (point)))
+ (while (not (zerop (geiser-syntax--nesting-level)))
+ (backward-up-list))
+ (multiple-value-bind (form end)
+ (geiser-syntax--form-after-point boundary)
+ (geiser-syntax--scan-locals form (> end boundary) '()))))))
;;; Fontify strings as Scheme code:
+(geiser-popup--define syntax " *geiser syntax analyst*" scheme-mode)
+
(defun geiser-syntax--font-lock-buffer ()
(let ((name " *geiser font lock*"))
(or (get-buffer name)
diff --git a/elisp/geiser-version.el.in b/elisp/geiser-version.el.in
new file mode 100644
index 0000000..5b1258b
--- /dev/null
+++ b/elisp/geiser-version.el.in
@@ -0,0 +1,12 @@
+
+;;; Versioning:
+
+(defvar geiser-version-string "@PACKAGE_STRING@"
+ "Geiser's version as a string.")
+
+(defun geiser-version ()
+ "Echoes Geiser's version."
+ (interactive)
+ (message "%s" geiser-version-string))
+
+(provide 'geiser-version)
diff --git a/elisp/geiser.el b/elisp/geiser.el
index b12127c..64d4efb 100644
--- a/elisp/geiser.el
+++ b/elisp/geiser.el
@@ -27,9 +27,6 @@
;;; Locations:
-(defvar geiser-root-dir nil
- "Geiser's root directory.")
-
(defvar geiser-elisp-dir nil
"Directory containing Geiser's Elisp files.")
@@ -37,14 +34,19 @@
"Directory containing Geiser's Scheme files.")
(setq geiser-elisp-dir (file-name-directory load-file-name))
-(setq geiser-scheme-dir (expand-file-name "../scheme/" geiser-elisp-dir))
-(setq geiser-root-dir (expand-file-name "../" geiser-elisp-dir))
-
(add-to-list 'load-path geiser-elisp-dir)
+(setq geiser-scheme-dir (expand-file-name "../scheme/" geiser-elisp-dir))
+
;;; Autoloads:
+(autoload 'geiser-version "geiser-version.el" "Echo Geiser's version." t)
+
+(autoload 'geiser-unload "geiser-reload.el" "Unload all Geiser code." t)
+
+(autoload 'geiser-reload "geiser-reload.el" "Reload Geiser code." t)
+
(autoload 'geiser "geiser-repl.el"
"Start a Geiser REPL, or switch to a running one." t)
@@ -85,94 +87,15 @@
geiser-faces
geiser-mode
geiser-guile
- geiser-plt))
-
-
-;;; Scheme mode setup:
-
-(defun geiser-setup-scheme-mode ()
- (eval-after-load "scheme"
- '(add-hook 'scheme-mode-hook 'turn-on-geiser-mode)))
-
-(defun geiser-setup-implementations (impls)
- (setq geiser-impl-installed-implementations (or impls '(guile plt))))
-
-(defsubst geiser-impl--impl-feature (impl)
- (intern (format "geiser-%s" impl)))
-
-(defun geiser-setup (&rest impls)
- (geiser-setup-implementations impls)
- (geiser-setup-scheme-mode)
- (mapc (lambda (impl)
- (require (geiser-impl--impl-feature impl) nil t))
- geiser-impl-installed-implementations))
-
-
-;;; Reload:
-
-(defmacro geiser--features-list ()
- (quote '(
- geiser-mode
- geiser-repl
- geiser-impl
- geiser-doc
- geiser-xref
- geiser-edit
- geiser-completion
- geiser-autodoc
- geiser-compile
- geiser-debug
- geiser-eval
- geiser-connection
- geiser-syntax
- geiser-log
- geiser-custom
- geiser-base
- geiser-popup
- )))
-
-(defun geiser-unload-function ()
- (dolist (feature (geiser--features-list))
- (when (featurep feature) (unload-feature feature t)))
- t)
-
-(defun geiser-unload ()
- (interactive)
- (when (featurep 'geiser) (unload-feature 'geiser)))
-
-(defun geiser-reload (&optional arg)
- "Reload Geiser.
-With prefix arg, prompts for the DIRECTORY in which Geiser should be
-loaded."
- (interactive "P")
- (let* ((dir (or (and arg (read-directory-name "New Geiser root dir: "
- geiser-root-dir
- geiser-root-dir
- t
- geiser-root-dir))
- geiser-root-dir))
- (geiser-main-file (expand-file-name "elisp/geiser.el" dir))
- (impls (and (featurep 'geiser-impl) geiser-impl--impls))
- (repls (and (featurep 'geiser-repl) (geiser-repl--repl-list)))
- (buffers (and (featurep 'geiser-mode) (geiser-mode--buffers))))
- (unless (file-exists-p geiser-main-file)
- (error "%s does not contain Geiser!" dir))
- (geiser-unload)
- (setq load-path (remove geiser-elisp-dir load-path))
- (load-file geiser-main-file)
- (geiser-setup)
- (dolist (feature (reverse (geiser--features-list)))
- (load-library (format "%s" feature)))
- (geiser-impl--reload-implementations impls)
- (geiser-repl--restore repls)
- (geiser-mode--restore buffers)
- (message "Geiser reloaded!")))
+ geiser-plt
+ geiser-impl
+ geiser-xref))
-;; Initialization:
+;;; Setup:
-(geiser-setup)
+(eval-after-load "scheme"
+ '(add-hook 'scheme-mode-hook 'turn-on-geiser-mode))
(provide 'geiser)
-;;; geiser.el ends here
diff --git a/scheme/Makefile.am b/scheme/Makefile.am
new file mode 100644
index 0000000..01ed6ca
--- /dev/null
+++ b/scheme/Makefile.am
@@ -0,0 +1,16 @@
+
+nobase_dist_pkgdata_DATA = \
+ guile/geiser/completion.scm \
+ guile/geiser/doc.scm \
+ guile/geiser/emacs.scm \
+ guile/geiser/evaluation.scm \
+ guile/geiser/modules.scm \
+ guile/geiser/utils.scm \
+ guile/geiser/xref.scm \
+ plt/geiser.ss \
+ plt/geiser/autodoc.ss \
+ plt/geiser/completions.ss \
+ plt/geiser/eval.ss \
+ plt/geiser/locations.ss \
+ plt/geiser/modules.ss \
+ plt/geiser/utils.ss
diff --git a/scheme/guile/geiser/completion.scm b/scheme/guile/geiser/completion.scm
index f4342bb..564b8f5 100644
--- a/scheme/guile/geiser/completion.scm
+++ b/scheme/guile/geiser/completion.scm
@@ -31,28 +31,9 @@
#:use-module (ice-9 session)
#:use-module (ice-9 regex))
-(define (completions prefix . context)
- (let ((context (and (not (null? context)) (car context)))
- (prefix (string-append "^" (regexp-quote prefix))))
- (append (filter (lambda (s) (string-match prefix s))
- (map symbol->string (local-bindings context)))
- (sort! (map symbol->string (apropos-internal prefix)) string<?))))
-
-(define (local-bindings form)
- (define (body f) (if (> (length f) 2) (cddr f) '()))
- (let loop ((form form) (bindings '()))
- (cond ((not (pair? form)) bindings)
- ((list? (car form))
- (loop (cdr form) (append (local-bindings (car form)) bindings)))
- ((and (list? form) (< (length form) 2)) bindings)
- ((memq (car form) '(define define* lambda))
- (loop (body form) (append (pair->list (cadr form)) bindings)))
- ((and (memq (car form) '(let let* letrec letrec*))
- (list? (cadr form)))
- (loop (body form) (append (map car (cadr form)) bindings)))
- ((and (eq? 'let (car form)) (symbol? (cadr form)))
- (loop (cons 'let (body form)) (cons (cadr form) bindings)))
- (else (loop (cdr form) bindings)))))
+(define (completions prefix)
+ (let ((prefix (string-append "^" (regexp-quote prefix))))
+ (sort! (map symbol->string (apropos-internal prefix)) string<?)))
(define (module-completions prefix)
(let* ((prefix (string-append "^" (regexp-quote prefix)))
diff --git a/scheme/guile/geiser/doc.scm b/scheme/guile/geiser/doc.scm
index c61502e..52f5625 100644
--- a/scheme/guile/geiser/doc.scm
+++ b/scheme/guile/geiser/doc.scm
@@ -37,82 +37,41 @@
#:use-module (oop goops)
#:use-module (srfi srfi-1))
-(define (autodoc form)
- (cond ((null? form) #f)
- ((symbol? form) (describe-application (list form)))
- ((not (pair? form)) #f)
- ((not (list? form)) (autodoc (pair->list form)))
- ((define-head? form) => autodoc)
- (else (autodoc/list form))))
-
-(define (autodoc/list form)
- (let ((lst (last form)))
- (cond ((and (symbol? lst) (describe-application (list lst))))
- ((and (pair? lst) (not (memq (car lst) '(quote))) (autodoc lst)))
- (else (describe-application form)))))
-
-(define (define-head? form)
- (define defforms '(define define* define-macro define-macro*
- define-method define-class define-generic))
- (and (= 2 (length form))
- (memq (car form) defforms)
- (car form)))
-
-(define (describe-application form)
- (let* ((fun (car form))
- (args (obj-args (symbol->object fun))))
+(define (autodoc ids)
+ (if (not (list? ids))
+ '()
+ (map (lambda (id) (or (autodoc* id) (list id))) ids)))
+
+(define (autodoc* id)
+ (let ((args (obj-args (symbol->object id))))
(and args
- (list (cons 'signature (signature fun args))
- (cons 'position (find-position args form))
- (cons 'module (symbol-module fun))))))
+ `(,@(signature id args)
+ (module . ,(symbol-module id))))))
(define (object-signature name obj)
(let ((args (obj-args obj)))
(and args (signature name args))))
-(define (signature fun args)
- (let ((req (arglst args 'required))
- (opt (arglst args 'optional))
- (key (arglst args 'keyword))
- (rest (assq-ref args 'rest)))
- (let ((sgn `(,fun ,@req
- ,@(if (not (null? opt)) (cons #:opt opt) '())
- ,@(if (not (null? key)) (cons #:key key) '()))))
- (if rest `(,@sgn #:rest ,rest) sgn))))
-
-(define (find-position args form)
- (let* ((lf (length form))
- (lf-1 (- lf 1)))
- (if (= 1 lf) 0
- (let ((req (length (arglst args 'required)))
- (opt (length (arglst args 'optional)))
- (keys (map (lambda (k) (symbol->keyword (if (list? k) (car k) k)))
- (arglst args 'keyword)))
- (rest (assq-ref args 'rest)))
- (cond ((<= lf (+ 1 req)) lf-1)
- ((<= lf (+ 1 req opt)) (if (> opt 0) lf lf-1))
- ((or (memq (last form) keys)
- (memq (car (take-right form 2)) keys)) =>
- (lambda (sl)
- (+ 2 req
- (if (> opt 0) (+ 1 opt) 0)
- (- (length keys) (length sl)))))
- (else (+ 1 req
- (if (> opt 0) (+ 1 opt) 0)
- (if (null? keys) 0 (+ 1 (length keys)))
- (if rest 2 0))))))))
-
-(define (arglst args kind)
- (let ((args (assq-ref args kind)))
- (cond ((or (not args) (null? args)) '())
- ((list? args) args)
- (else (list args)))))
+(define (signature id args)
+ (define (arglst kind)
+ (let ((args (assq-ref args kind)))
+ (cond ((or (not args) (null? args)) '())
+ ((list? args) args)
+ (else (list args)))))
+ `(,id
+ (args ,@(if (list? args)
+ `((required ,@(arglst 'required))
+ (optional ,@(arglst 'optional)
+ ,@(let ((rest (assq-ref args 'rest)))
+ (if rest (list "...") '())))
+ (key ,@(arglst 'keyword)))
+ '()))))
(define (obj-args obj)
(cond ((not obj) #f)
((or (procedure? obj) (program? obj)) (arguments obj))
((macro? obj) (or (obj-args (macro-transformer obj)) '((required ...))))
- (else #f)))
+ (else 'variable)))
(define (arguments proc)
(cond
diff --git a/scheme/guile/geiser/emacs.scm b/scheme/guile/geiser/emacs.scm
index edae487..2aa91da 100644
--- a/scheme/guile/geiser/emacs.scm
+++ b/scheme/guile/geiser/emacs.scm
@@ -39,7 +39,8 @@
ge:module-exports
ge:module-location
ge:callers
- ge:callees)
+ ge:callees
+ ge:find-file)
#:use-module (geiser evaluation)
#:use-module ((geiser modules) :renamer (symbol-prefix-proc 'ge:))
#:use-module ((geiser completion) :renamer (symbol-prefix-proc 'ge:))
diff --git a/scheme/guile/geiser/evaluation.scm b/scheme/guile/geiser/evaluation.scm
index 537e145..cbc088e 100644
--- a/scheme/guile/geiser/evaluation.scm
+++ b/scheme/guile/geiser/evaluation.scm
@@ -47,53 +47,47 @@
(else (display (format "ERROR: ~a, args: ~a" (car args) (cdr args)))))
`(error (key . ,(car args))))
-(define (evaluate form module-name evaluator)
- (let ((module (or (and (list? module-name)
- (resolve-module module-name))
- (current-module)))
- (evaluator (lambda (f m)
- (call-with-values (lambda () (evaluator f m)) list)))
- (result #f)
- (captured-stack #f)
- (error #f))
+(define (ge:compile form module-name)
+ (let* ((module (or (and (list? module-name)
+ (resolve-module module-name))
+ (current-module)))
+ (result #f)
+ (captured-stack #f)
+ (error #f)
+ (ev (lambda ()
+ (save-module-excursion
+ (lambda ()
+ (set-current-module module)
+ (set! result (call-with-values
+ (lambda () (compile form))
+ (lambda vs
+ (map (lambda (v)
+ (with-output-to-string
+ (lambda () (write v))))
+ vs)))))))))
(let ((output
(with-output-to-string
(lambda ()
- (set! result
- (catch #t
- (lambda ()
- (start-stack 'geiser-eval (evaluator form module)))
- (lambda args
- (set! error #t)
- (apply handle-error captured-stack args))
- (lambda args
- (set! captured-stack (make-stack #t 1 13)))))))))
+ (catch #t
+ (lambda () (start-stack 'geiser-eval (ev)))
+ (lambda args
+ (set! error #t)
+ (apply handle-error captured-stack args))
+ (lambda args
+ (set! captured-stack (make-stack #t 2 15))))))))
(write `(,(if error result (cons 'result result))
(output . ,output)))
(newline))))
-(define (eval-compile form module)
- (save-module-excursion
- (lambda ()
- (set-current-module module)
- (compile form))))
-
-(define (ge:eval form module-name)
- (evaluate form module-name eval))
-
-(define (ge:compile form module-name)
- (evaluate form module-name eval-compile))
+(define ge:eval ge:compile)
(define (ge:compile-file path)
- "Compile and load file, given its full @var{path}."
- (evaluate `(and (compile-file ,path)
- (load-compiled ,(compiled-file-name path)))
- '(system base compile)
- eval-compile))
+ "Compile a file, given its full @var{path}."
+ (ge:compile `(compile-and-load ,path) '(geiser evaluation)))
(define (ge:load-file path)
"Load file, given its full @var{path}."
- (evaluate `(load ,path) #f eval))
+ (ge:compile `(load-compiled ,(compiled-file-name path)) '(geiser evaluation)))
(define (ge:macroexpand form . all)
(let ((all (and (not (null? all)) (car all))))
diff --git a/scheme/guile/geiser/xref.scm b/scheme/guile/geiser/xref.scm
index f00f724..2336fb2 100644
--- a/scheme/guile/geiser/xref.scm
+++ b/scheme/guile/geiser/xref.scm
@@ -28,7 +28,8 @@
#:export (symbol-location
generic-methods
callers
- callees)
+ callees
+ find-file)
#:use-module (geiser utils)
#:use-module (geiser modules)
#:use-module (geiser doc)
@@ -90,4 +91,10 @@
(and obj
(map procedure-xref (procedure-callees obj)))))
+(define (find-file path)
+ (let loop ((dirs %load-path))
+ (if (null? dirs) #f
+ (let ((candidate (string-append (car dirs) "/" path)))
+ (if (file-exists? candidate) candidate (loop (cdr dirs)))))))
+
;;; xref.scm ends here
diff --git a/scheme/plt/geiser/autodoc.ss b/scheme/plt/geiser/autodoc.ss
index 73ed24d..c43f8c9 100644
--- a/scheme/plt/geiser/autodoc.ss
+++ b/scheme/plt/geiser/autodoc.ss
@@ -31,39 +31,32 @@
(eval `(help ,symbol #:from ,mod)))))
(eval `(help ,symbol))))
-(define (autodoc form)
- (cond ((null? form) #f)
- ((symbol? form) (describe-application (list form)))
- ((not (pair? form)) #f)
- ((not (list? form)) (autodoc (pair->list form)))
- ((define-head? form) => autodoc)
- (else (autodoc/list form))))
-
-(define (autodoc/list form)
- (let ((lst (last form)))
- (cond ((and (symbol? lst) (describe-application (list lst))))
- ((and (pair? lst) (not (memq (car lst) '(quote))) (autodoc lst)))
- (else (describe-application form)))))
-
-(define (define-head? form)
- (define defforms '(-define
- define define-values
- define-method define-class define-generic define-struct
- define-syntax define-syntaxes -define-syntax))
- (and (= 2 (length form))
- (memq (car form) defforms)
- (car form)))
-
-(define (describe-application form)
- (let* ((fun (car form))
- (loc (symbol-location* fun))
- (name (car loc))
- (path (cdr loc))
- (sgn (and path (find-signature path name fun))))
- (and sgn
- (list (cons 'signature (format-signature fun sgn))
- (cons 'position (find-position sgn form))
- (cons 'module (module-path-name->name path))))))
+(define (autodoc ids)
+ (if (not (list? ids))
+ '()
+ (map (lambda (id) (or (autodoc* id) (list id))) ids)))
+
+(define (autodoc* id)
+ (and
+ (symbol? id)
+ (let* ((loc (symbol-location* id))
+ (name (car loc))
+ (path (cdr loc))
+ (sgn (and path (find-signature path name id))))
+ (and sgn
+ `(,id
+ (name . ,name)
+ (args ,@(format-signature sgn))
+ (module . ,(module-path-name->name path)))))))
+
+(define (format-signature sign)
+ (if (signature? sign)
+ `((required ,@(signature-required sign))
+ (optional ,@(signature-optional sign)
+ ,@(let ((rest (signature-rest sign)))
+ (if rest (list "...") '())))
+ (key ,@(signature-keys sign)))
+ '()))
(define signatures (make-hash))
@@ -71,9 +64,7 @@
(define (find-signature path name local-name)
(let ((path (if (path? path) (path->string path) path)))
- (hash-ref! (hash-ref! signatures
- path
- (lambda () (parse-signatures path)))
+ (hash-ref! (hash-ref! signatures path (lambda () (parse-signatures path)))
name
(lambda () (infer-signature local-name)))))
@@ -167,44 +158,6 @@
(opt-no (- max-val min-val)))
(make-signature (args 0 min-val) (args min-val opt-no) '() #f)))))
-(define (format-signature fun sign)
- (cond ((symbol? sign) (cons fun sign))
- ((signature? sign)
- (let ((req (signature-required sign))
- (opt (signature-optional sign))
- (keys (signature-keys sign))
- (rest (signature-rest sign)))
- `(,fun
- ,@req
- ,@(if (null? opt) opt (cons '#:opt opt))
- ,@(if (null? keys) keys (cons '#:key keys))
- ,@(if rest (list '#:rest rest) '()))))
- (else #f)))
-
-(define (find-position sign form)
- (if (signature? sign)
- (let* ((lf (length form))
- (lf-1 (- lf 1)))
- (if (= 1 lf) 0
- (let ((req (length (signature-required sign)))
- (opt (length (signature-optional sign)))
- (keys (map (lambda (k) (symbol->keyword (if (list? k) (car k) k)))
- (signature-keys sign)))
- (rest (signature-rest sign)))
- (cond ((<= lf (+ 1 req)) lf-1)
- ((<= lf (+ 1 req opt)) (if (> opt 0) lf lf-1))
- ((or (memq (last form) keys)
- (memq (car (take-right form 2)) keys)) =>
- (lambda (sl)
- (+ 2 req
- (if (> opt 0) (+ 1 opt) 0)
- (- (length keys) (length sl)))))
- (else (+ 1 req
- (if (> opt 0) (+ 1 opt) 0)
- (if (null? keys) 0 (+ 1 (length keys)))
- (if rest 2 0)))))))
- 0))
-
(define (update-module-cache path . form)
(when (and (string? path)
(or (null? form)
diff --git a/scheme/plt/geiser/completions.ss b/scheme/plt/geiser/completions.ss
index 4537feb..15bc081 100644
--- a/scheme/plt/geiser/completions.ss
+++ b/scheme/plt/geiser/completions.ss
@@ -35,29 +35,10 @@
(filter (lambda (s) (string-prefix? prefix s))
(if sort? (sort lst string<?) lst)))
-(define (symbol-completions prefix (context #f))
- (append (filter-prefix prefix
- (map symbol->string (local-bindings context))
- #f)
- (filter-prefix prefix
- (map symbol->string (namespace-mapped-symbols))
- #t)))
-
-(define (local-bindings form)
- (define (body f) (if (> (length f) 2) (cddr f) '()))
- (let loop ((form form) (bindings '()))
- (cond ((not (pair? form)) bindings)
- ((list? (car form))
- (loop (cdr form) (append (local-bindings (car form)) bindings)))
- ((and (list? form) (< (length form) 2)) bindings)
- ((memq (car form) '(define define* lambda))
- (loop (body form) (append (pair->list (cadr form)) bindings)))
- ((and (memq (car form) '(let let* letrec letrec*))
- (list? (cadr form)))
- (loop (body form) (append (map car (cadr form)) bindings)))
- ((and (eq? 'let (car form)) (symbol? (cadr form)))
- (loop (cons 'let (body form)) (cons (cadr form) bindings)))
- (else (loop (cdr form) bindings)))))
+(define (symbol-completions prefix)
+ (filter-prefix prefix
+ (map symbol->string (namespace-mapped-symbols))
+ #t))
(define (module-completions prefix)
(filter-prefix prefix (module-list) #f))
diff --git a/scheme/plt/geiser/eval.ss b/scheme/plt/geiser/eval.ss
index 8022a4c..5ae81ed 100644
--- a/scheme/plt/geiser/eval.ss
+++ b/scheme/plt/geiser/eval.ss
@@ -46,36 +46,37 @@
(vector-ref (struct->vector e) 0))
(define (set-last-error e)
- (set! last-result `((error (key . ,(exn-key e))
- (subr)
- (msg . ,(exn-message e))))))
+ (set! last-result `((error (key . ,(exn-key e)))))
+ (display (exn-message e)))
-(define (set-last-result v . vs)
- (set! last-result `((result ,v ,@vs))))
+(define (write-value v)
+ (with-output-to-string
+ (lambda () (write v))))
+
+(define (set-last-result . vs)
+ (set! last-result `((result ,@(map write-value vs)))))
(define (eval-in form spec)
(set-last-result (void))
- (with-handlers ((exn? set-last-error))
- (update-module-cache spec form)
- (call-with-values
- (lambda () (eval form (module-spec->namespace spec)))
- set-last-result))
- last-result)
+ (let ((output
+ (with-output-to-string
+ (lambda ()
+ (with-handlers ((exn? set-last-error))
+ (update-module-cache spec form)
+ (call-with-values
+ (lambda () (eval form (module-spec->namespace spec)))
+ set-last-result))))))
+ (append last-result `((output . ,output)))))
(define compile-in eval-in)
(define (load-file file)
- (with-handlers ((exn? set-last-error))
- (let ((current-path (namespace->module-path-name (last-namespace))))
- (update-module-cache file)
- (set-last-result
- (string-append (with-output-to-string
- (lambda ()
- (load-module file (current-output-port))))
- "done."))
- (load-module (and (path? current-path)
- (path->string current-path)))))
- last-result)
+ (let ((current-path (namespace->module-path-name (last-namespace)))
+ (result (eval-in `(load-module ,file (current-output-port))
+ 'geiser/eval)))
+ (update-module-cache file)
+ (load-module (and (path? current-path) (path->string current-path)))
+ result))
(define compile-file load-file)