mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-24 04:15:36 +02:00
Code Activity

* Add non-libguile Elisp support files to CVS trunk. (NB work in progress.)

Browse source
This commit is contained in:
Neil Jerram 2002-01-22 23:46:01 +00:00
parent c96d76b88d
commit 3d1a89b9ee
46 changed files with 2139 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

15
ChangeLog
View file

@ -1,3 +1,18 @@
2002-01-13 Neil Jerram <neil@ossau.uklinux.net>
* Makefile.am (SUBDIRS): Added lang.
* configure.in (AC_CONFIG_FILES): Added Makefiles in lang,
lang/elisp, lang/elisp/internals and lang/elisp/primitives.
2002-01-11 Neil Jerram <neil@ossau.uklinux.net>
* acconfig.h (SCM_ENABLE_ELISP): New conditional.
* configure.in (SCM_ENABLE_ELISP): Define this conditional (or
not) according to absence (or presence) of `--disable-elisp'
in the configure args.
2001-12-31 Dirk Herrmann <D.Herrmann@tu-bs.de> 2001-12-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
* TODO: Added two items. * TODO: Added two items.

2
Makefile.am
View file

@ -21,7 +21,7 @@
SUBDIRS = oop qt libltdl libguile ice-9 guile-config guile-readline \ SUBDIRS = oop qt libltdl libguile ice-9 guile-config guile-readline \
scripts srfi doc examples test-suite scripts srfi doc examples test-suite lang
bin_SCRIPTS = guile-tools bin_SCRIPTS = guile-tools

3
acconfig.h
View file

@ -134,6 +134,9 @@
/* Define this if you want support for arrays and uniform arrays. */ /* Define this if you want support for arrays and uniform arrays. */
#undef HAVE_ARRAYS #undef HAVE_ARRAYS
/* Define this if you want Elisp support (in addition to Scheme). */
#undef SCM_ENABLE_ELISP
/* Define this if your IPv6 has sin6_scope_id in sockaddr_in6 struct. */ /* Define this if your IPv6 has sin6_scope_id in sockaddr_in6 struct. */
#undef HAVE_SIN6_SCOPE_ID #undef HAVE_SIN6_SCOPE_ID

12
configure.in
View file

@ -129,6 +129,10 @@ dnl a required part of the distribution.
AC_DEFINE(DEBUG_EXTENSIONS) AC_DEFINE(DEBUG_EXTENSIONS)
AC_DEFINE(READER_EXTENSIONS) AC_DEFINE(READER_EXTENSIONS)
AC_ARG_ENABLE(elisp,
[ --disable-elisp omit Emacs Lisp support],,
enable_elisp=yes)
dnl files which are destined for separate modules. dnl files which are destined for separate modules.
if test "$enable_arrays" = yes; then if test "$enable_arrays" = yes; then
@ -150,6 +154,10 @@ if test "$enable_debug_malloc" = yes; then
LIBOBJS="$LIBOBJS debug-malloc.o" LIBOBJS="$LIBOBJS debug-malloc.o"
fi fi
if test "$enable_elisp" = yes; then
AC_DEFINE(SCM_ENABLE_ELISP)
fi
#-------------------------------------------------------------------- #--------------------------------------------------------------------
dnl Some more checks for Win32 dnl Some more checks for Win32
@ -660,6 +668,10 @@ AC_CONFIG_FILES([
libguile/guile-snarf-docs-texi libguile/guile-snarf-docs-texi
libguile/version.h libguile/version.h
ice-9/Makefile ice-9/Makefile
lang/Makefile
lang/elisp/Makefile
lang/elisp/internals/Makefile
lang/elisp/primitives/Makefile
oop/Makefile oop/Makefile
oop/goops/Makefile oop/goops/Makefile
scripts/Makefile scripts/Makefile

2
lang/.cvsignore Normal file
View file

@ -0,0 +1,2 @@
Makefile
Makefile.in

24
lang/Makefile.am Normal file
View file

@ -0,0 +1,24 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 2000 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as
## published by the Free Software Foundation; either version 2, or
## (at your option) any later version.
##
## GUILE 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 GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
AUTOMAKE_OPTIONS = gnu
SUBDIRS = elisp

2
lang/elisp/.cvsignore Normal file
View file

@ -0,0 +1,2 @@
Makefile
Makefile.in

194
lang/elisp/ChangeLog Normal file
View file

@ -0,0 +1,194 @@
2001-11-03 Neil Jerram <neil@ossau.uklinux.net>
* README (Resources): Fill in missing URLs.
2001-11-02 Neil Jerram <neil@ossau.uklinux.net>
* Makefile.am (elisp_sources): Added base.scm, example.el,
interface.scm; removed emacs.scm.
* README: Updated accordingly.
* internals/load.scm (load): Avoid using `load-path' if the
supplied file name begins with a slash.
* internals/fset.scm: Support export of defuns, defmacros and
defvars to a module specified by the fluid `elisp-export-module'.
This allows us to automate the importing of Elisp definitions into
Scheme.
* example.el: New file: example code for `load-elisp-file'.
* interface.scm: New file - mechanisms to exchange definitions
between Scheme and Elisp.
Following changes try to make the Elisp evaluation module less
Emacs-dependent; in other words, so that it isn't necessary to try
to load the whole Emacs environment before evaluating basic
non-Emacs-specific Elisp code.
* variables.scm, internals/evaluation.scm: Changed (lang elisp
emacs) to (lang elisp base).
* emacs.scm (lang): Removed.
* base.scm (lang): New file (non-emacs-specific replacement for
emacs.scm).
2001-10-28 Neil Jerram <neil@ossau.uklinux.net>
* primitives/symprop.scm (symbol-name): New primitive.
* primitives/strings.scm (stringp): New primitive.
* primitives/pure.scm (purify-flag): New variable.
* primitives/numbers.scm (numberp): New primitive.
* internals/fset.scm (fset): Set procedure and macro name
properties usefully to match Elisp symbol names. Also bind Elisp
function definition variables to similarly named symbols in the
(lang elisp variables) module.
* transform.scm (transformer, m-unwind-protect): Added support for
`unwind-protect'.
(m-quasiquote): Use 'quasiquote rather than 'quote.
(transform-lambda, m-defmacro): When no rest arguments, set the
rest parameter to '() rather than #f. It shouldn't make any
difference, but it feels more right.
* README: Enlarged description of current status.
* Makefile.am (elisp_sources): Added variables.scm.
* variables.scm: New file.
2001-10-26 Neil Jerram <neil@ossau.uklinux.net>
* buffers.scm, calling.scm: Removed. These should have
disappeared during the reorganization described below, but I
missed them by mistake.
* primitives/symprop.scm (set, boundp, symbol-value): Changed to
use (module-xx the-elisp-module ...) rather than (local-xx ...).
(symbolp): Accept either symbols or keywords.
(set-default, default-boundp, default-value,
local-variable-if-set-p): New.
* primitives/match.scm (string-match, match-data): Store last
match data in Emacs rather than Guile form, to simplify
implementation of ...
(set-match-data, store-match-data): New.
* primitives/load.scm (autoload, current-load-list): New. (But
autoload is just stubbed, not properly implemented.)
* primitives/lists.scm (nth, listp, consp, nconc): New.
* primitives/fns.scm (byte-code-function-p, run-hooks): New.
* transform.scm (transform-application, transformer-macro): New
scheme for transforming procedure arguments while leaving macro
args untransformed. (See also associated change in libguile.)
(m-defconst): Simplified, now uses m-setq.
* Makefile.am: Changed so that it only deals with files directly
in this directory; otherwise files don't install cleanly.
* internals/Makefile.am, primitives/Makefile.am,
internals/.cvsignore, primitives/.cvsignore: New files.
2001-10-26 Neil Jerram <neil@ossau.uklinux.net>
* transform.scm (transformer): New handling for (1) quasiquoting
syntax like "(` ...)" as well as the more normal "` ..."; (2)
`function'; (3) interactive specification in lambda body.
Simplied handling for `setq'.
(transform-inside-qq): Fixed to handle improper as well as proper
lists.
(transform-lambda/interactive): New; wraps transform-lambda to
handle setting of various procedure properties.
(transform-lambda, m-defmacro): Changed `args' and `num-args' to
`%--args' and `%--num-args' in the hope of avoiding lexical
vs. dynamic name clashes.
(m-and): Use #f instead of '() where a condition fails.
Plus big hierarchy reorganization, in which most of the previous
occupants of lang/elisp moved to lang/elisp/primitives, with some
internal processing being split out into lang/elisp/internals.
The upshot looks like this:
* internals/trace.scm, internals/set.scm, internals/load.scm,
internals/fset.scm, internals/signal.scm, internals/time.scm,
internals/format.scm, internals/null.scm,
internals/evaluation.scm, primitives/buffers.scm,
primitives/features.scm, primitives/format.scm,
primitives/time.scm, primitives/guile.scm, primitives/keymaps.scm,
primitives/lists.scm, primitives/load.scm, primitives/match.scm,
primitives/numbers.scm, primitives/pure.scm, primitives/read.scm,
primitives/signal.scm, primitives/strings.scm,
primitives/symprop.scm, primitives/system.scm, primitives/fns.scm:
New files.
* features.scm, format.scm, fset.scm, guile.scm, keymaps.scm,
lists.scm, load.scm, match.scm, numbers.scm, pure.scm, read.scm,
signal.scm, strings.scm, symprop.scm, system.scm, time.scm,
trace.scm: Removed files.
2001-10-23 Neil Jerram <neil@ossau.uklinux.net>
* match.scm (string-match): New implementation using new
`make-emacs-regexp' primitive; old workaround implementation
renamed to `string-match-workaround'.
2001-10-21 Neil Jerram <neil@ossau.uklinux.net>
* transform.scm (m-defun, m-defmacro, m-let, m-defvar,
m-defconst): Use more selective tracing mechanism (provided by new
file trace.scm).
* symprop.scm (get, boundp), transform.scm (transform-lambda,
m-defmacro): Remove unnecessary uses of nil-ify and t-ify.
* match.scm (string-match): Workaround Guile/libc regex
parenthesis bug.
* emacs.scm: Move elisp primitive definitions into more specific
files, so that emacs.scm contains only overall code.
* Makefile.am: Added new files.
* numbers.scm, trace.scm, time.scm, pure.scm, system.scm,
read.scm, calling.scm, guile.scm: New files.
2001-10-20 Neil Jerram <neil@ossau.uklinux.net>
* Makefile.am (elisp_sources): Added match.scm and strings.scm.
* match.scm, strings.scm: New files.
2001-10-19 Neil Jerram <neil@ossau.uklinux.net>
* transform.scm: Replace uses of `nil' by `#f' or `'()'.
* Makefile.am (elisp_sources): Added lists.scm.
* load.scm (the-elisp-module): Corrected (lang elisp emacs) module
name.
* lists.scm (lang): New file containing list-related primitives.
* emacs.scm: Corrected module name.
2001-10-19 Neil Jerram <neil@ossau.uklinux.net>
Initial implementation of an Emacs Lisp translator, based on
transformer code originally written by Mikael Djurfeldt.
* Makefile.am, .cvsignore: New.
* ChangeLog, README, buffers.scm, emacs.scm, features.scm,
format.scm, fset.scm, keymaps.scm, load.scm, signal.scm,
symprop.scm, transform.scm: New files.

39
lang/elisp/Makefile.am Normal file
View file

@ -0,0 +1,39 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as
## published by the Free Software Foundation; either version 2, or
## (at your option) any later version.
##
## GUILE 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 GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
AUTOMAKE_OPTIONS = gnu
SUBDIRS = internals primitives
# These should be installed and distributed.
elisp_sources = \
base.scm \
example.el \
interface.scm \
transform.scm \
variables.scm
subpkgdatadir = $(pkgdatadir)/$(VERSION)/lang/elisp
subpkgdata_DATA = $(elisp_sources)
ETAGS_ARGS = $(subpkgdata_DATA)
EXTRA_DIST = $(elisp_sources)

321
lang/elisp/README Normal file
View file

@ -0,0 +1,321 @@
-*- outline -*-
This directory holds the Scheme side of a translator for Emacs Lisp.
* Usage
To load up the base Elisp environment:
(use-modules (lang elisp base))
Then you can switch into this module
(define-module (lang elisp base))
and start typing away in Elisp, or evaluate an individual Elisp
expression from Scheme:
(eval EXP (resolve-module '(lang elisp base)))
A more convenient, higher-level interface is provided by (lang elisp
interface):
(use-modules (lang elisp interface))
With this interface, you can evaluate an Elisp expression
(eval-elisp EXP)
load an Elisp file with no effect on the Scheme world
(load-elisp-file "/home/neil/Guile/cvs/guile-core/lang/elisp/example.el")
load an Elisp file, automatically importing top level definitions into
Scheme
(use-elisp-file "/home/neil/Guile/cvs/guile-core/lang/elisp/example.el")
export Scheme objects to Elisp
(export-to-elisp + - * my-func 'my-var)
and try to bootstrap a complete Emacs environment:
(load-emacs)
* Status
Please note that this is work in progress; the translator is
incomplete and not yet widely tested.
** Trying to load a complete Emacs environment.
To try this, type `(use-modules (lang elisp interface))' and then
`(load-emacs)'. The following output shows how far I get when I try
this.
guile> (use-modules (lang elisp interface))
guile> (load-emacs)
Calling loadup.el to clothe the bare Emacs...
Loading /usr/share/emacs/20.7/lisp/loadup.el...
Using load-path ("/usr/share/emacs/20.7/lisp/" "/usr/share/emacs/20.7/lisp/emacs-lisp/")
Loading /usr/share/emacs/20.7/lisp/byte-run.el...
Loading /usr/share/emacs/20.7/lisp/byte-run.el...done
Loading /usr/share/emacs/20.7/lisp/subr.el...
Loading /usr/share/emacs/20.7/lisp/subr.el...done
Loading /usr/share/emacs/20.7/lisp/version.el...
Loading /usr/share/emacs/20.7/lisp/version.el...done
Loading /usr/share/emacs/20.7/lisp/map-ynp.el...
Loading /usr/share/emacs/20.7/lisp/map-ynp.el...done
Loading /usr/share/emacs/20.7/lisp/widget.el...
Loading /usr/share/emacs/20.7/lisp/emacs-lisp/cl.el...
Loading /usr/share/emacs/20.7/lisp/emacs-lisp/cl.el...done
Loading /usr/share/emacs/20.7/lisp/widget.el...done
Loading /usr/share/emacs/20.7/lisp/custom.el...
Loading /usr/share/emacs/20.7/lisp/custom.el...done
Loading /usr/share/emacs/20.7/lisp/cus-start.el...
Note, built-in variable `abbrev-all-caps' not bound
... [many other variable not bound messages] ...
Loading /usr/share/emacs/20.7/lisp/cus-start.el...done
Loading /usr/share/emacs/20.7/lisp/international/mule.el...
<unnamed port>: In procedure make-char-table in expression (@fop make-char-table (# #)):
<unnamed port>: Symbol's function definition is void
ABORT: (misc-error)
Type "(backtrace)" to get more information or "(debug)" to enter the debugger.
guile>
That's 3279 lines ("wc -l") of Elisp code already, which isn't bad!
I think that progress beyond this point basically means implementing
multilingual and multibyte strings properly for Guile. Which is a
_lot_ of work and requires IMO a very clear plan for Guile's role with
respect to Emacs.
* Design
When thinking about how to implement an Elisp translator for Guile, it
is important to realize that the great power of Emacs does not arise
from Elisp (seen as a language in syntactic terms) alone, but from the
combination of this language with the collection of primitives
provided by the Emacs C source code. Therefore, to be of practical
use, an Elisp translator needs to be more than just a transformer that
translates sexps to Scheme expressions.
The finished translator should consist of several parts...
** Syntax transformation
Although syntax transformation isn't all we need, we do still need it!
This part is implemented by the (lang elisp transform) module; it is
close to complete and seems to work pretty reliably.
Note that transformed expressions use the `@fop' and `@bind' macros
provided by...
** C support for transformed expressions
For performance and historical reasons (and perhaps necessity - I
haven't thought about it enough yet), some of the transformation
support is written in C.
*** @fop
The `@fop' macro is used to dispatch Elisp applications. Its first
argument is a symbol, and this symbol's function slot is examined to
find a procedure or macro to apply to the remaining arguments. `@fop'
also handles aliasing (`defalias'): in this case the function slot
contains another symbol.
Once `@fop' has found the appropriate procedure or macro to apply, it
returns an application expression in which that procedure or macro
replaces the `@fop' and the original symbol. Hence no Elisp-specific
evaluator support is required to perform the application.
*** @bind
Currently, Elisp variables are the same as Scheme variables, so
variable references are effectively untransformed.
The `@bind' macro does Elisp-style dynamic variable binding.
Basically, it locates the named top level variables, `set!'s them to
new values, evaluates its body, and then uses `set!' again to restore
the original values.
Because of the body evaluation, `@bind' requires evaluator support.
In fact, the `@bind' macro code does little more than replace itself
with the memoized SCM_IM_BIND. Most of the work is done by the
evaluator when it hits SCM_IM_BIND.
One theoretical problem with `@bind' is that any local Scheme variable
in the same scope and with the same name as an Elisp variable will
shadow the Elisp variable. But in practice it's difficult to set up
such a situation; an exception is the translator code itself, so there
we mangle the relevant Scheme variable names a bit to avoid the
problem.
Other possible problems with this approach are that it might not be
possible to implement buffer local variables properly, and that
`@bind' might become too inefficient when we implement full support
for undefining Scheme variables. So we might in future have to
transform Elisp variable references after all.
*** Truth value stuff
Lots of stuff to do with providing the special self-evaluating `nil'
and `t' symbols, and macros that convert between Scheme and Elisp
truth values, and so on.
I'm hoping that most of this will go away, but I need to show that
it's feasible first.
** Emacs editing primitives
Buffers, keymaps, text properties, windows, frames etc. etc.
Basically, everything that is implemented as a primitive in the Emacs
C code needs to be implemented either in Scheme or in C for Guile.
The Scheme files in the primitives subdirectory implement some of
these primitives in Scheme. Not because that is the right decision,
but because this is a proof of concept and it's quicker to write badly
performing code in Scheme.
Ultimately, most of these primitive definitions should really come
from the Emacs C code itself, translated or preprocessed in a way that
makes it compile with Guile. I think this is pretty close to the work
that Ken Raeburn has been doing on the Emacs codebase.
** Reading and printing support
Elisp is close enough to Scheme that it's convenient to coopt the
existing Guile reader rather than to write a new one from scratch, but
there are a few syntactic differences that will require adding Elisp
support to the reader.
- Character syntax is `?a' rather than `#\a'. (Not done. More
precisely, `?a' in Elisp isn't character syntax but an alternative
integer syntax. Note that we could support most of the `?a' syntax
simply by doing
(define ?a (char->integer #\a)
(define ?b (char->integer #\b)
and so on.)
- `nil' and `t' should be read (I think) as #f and #t. (Done.)
- Vector syntax is `[1 2 3]' rather than `#(1 2 3)'. (Not done.)
Correspondingly, when printing, #f and '() should be written as
`nil'. (Not done.)
** The Elisp evaluation module (lang elisp base)
Fundamentally, Guile's module system can't be used to package Elisp
code in the same way it is used for Scheme code, because Elisp
function definitions are stored as symbol properties (in the symbol's
"function slot") and so are global. On the other hand, it is useful
(necessary?) to associate some particular module with Elisp evaluation
because
- Elisp variables are currently implemented as Scheme variables and so
need to live in some module
- a syntax transformer is a property of a module.
Therefore we have the (lang elisp base) module, which acts as the
repository for all Elisp variables and the site of all Elisp
evaluation.
The initial environment provided by this module is intended to be a
non-Emacs-dependent subset of Elisp. To get the idea, imagine someone
who wants to write an extension function for, say Gnucash, and simply
prefers to write in Elisp rather than in Scheme. He/she therefore
doesn't buffers, keymaps and so on, just the basic language syntax and
core data functions like +, *, concat, length etc., plus specific
functions made available by Gnucash.
(lang elisp base) achieves this by
- importing Scheme definitions for some Emacs primitives from the
files in the primitives subdirectory
- then switching into Elisp syntax.
After this point, `(eval XXX (resolve-module '(lang elisp base)))'
will evaluate XXX as an Elisp expression in the (lang elisp base)
module. (`eval-elisp' in (lang elisp interface) is a more convenient
wrapper for this.)
** Full Emacs environment
The difference between the initial (lang elisp base) environment and a
fully loaded Emacs equivalent is
- more primitives: buffers, char-tables and many others
- the bootstrap Elisp code that an undumped Emacs loads during
installation by calling `(load "loadup.el")'.
We don't have all the missing primitives, but we can already get
through some of loadup.el. The Elisp function `load-emacs' (defined
in (lang elisp base) initiates the loading of loadup.el; (lang elisp
interface) exports `load-emacs' to Scheme.
`load-emacs' loads so much Elisp code that it's an excellent way to
test the translator. In current practice, it runs for a while and
then fails when it gets to an undefined primitive or a bug in the
translator. Eventually, it should go all the way. (And then we can
worry about adding unexec support to Guile!) For the output that
currently results from calling `(load-emacs)', see above in the Status
section.
* nil, #f and '()
For Jim Blandy's notes on this, see the reference at the bottom of
this file. Currently I'm investigating a different approach, which is
better IMO than Jim's proposal because it avoids requiring multiple
false values in the Scheme world.
According to my approach...
- `nil' and `t' are read (when in Elisp mode) as #f and #t.
- `(if x ...)', `(while x ...)' etc. are translated to something
like `(if (and x (not (null? x))) ...)'.
- Functions which interpret an argument as a list --
`cons', `setcdr', `memq', etc. -- either convert #f to '(), or
handle the #f case specially.
- `eq' treats #f and '() as the same.
- Optionally, functions which produce '() values -- i.e. the reader
and `cdr' -- could convert those immediately to #f. This shouldn't
affect the validity of any Elisp code, but it alters the balance of
#f and '() values swimming around in that code and so affects what
happens if two such values are returned to the Scheme world and then
compared. However, since you can never completely solve this
problem (unless you are prepared to convert arbitrarily deep
structures on entry to the Elisp world, which would kill performance),
I'm inclined not to try to solve it at all.
* Resources
** Ken Raeburn's Guile Emacs page
http://www.mit.edu/~raeburn/guilemacs/
** Keisuke Nishida's Gemacs project
http://gemacs.sourceforge.net
** Jim Blandy's nil/#f/() notes
http://sanpietro.red-bean.com/guile/guile/old/3114.html
** Mikael Djurfeldt's notes on translation
See file guile-cvs/devel/translation/langtools.text in Guile CVS.

38
lang/elisp/base.scm Normal file
View file

@ -0,0 +1,38 @@
(define-module (lang elisp base))
;;; {Elisp Primitives}
;;;
;;; In other words, Scheme definitions of elisp primitives. This
;;; should (ultimately) include everything that Emacs defines in C.
(use-modules (lang elisp primitives buffers)
(lang elisp primitives features)
(lang elisp primitives format)
(lang elisp primitives fns)
(lang elisp primitives guile)
(lang elisp primitives keymaps)
(lang elisp primitives lists)
(lang elisp primitives load)
(lang elisp primitives match)
(lang elisp primitives numbers)
(lang elisp primitives pure)
(lang elisp primitives read)
(lang elisp primitives signal)
(lang elisp primitives strings)
(lang elisp primitives symprop)
(lang elisp primitives system)
(lang elisp primitives time))
;;; Now switch into Emacs Lisp syntax.
(use-modules (lang elisp transform))
(read-set! keywords 'prefix)
(read-set! language 'elisp)
(set-module-transformer! (current-module) transformer)
;;; Everything below here is written in Elisp.
(defun load-emacs ()
(message "Calling loadup.el to clothe the bare Emacs...")
(load "loadup.el")
(message "Guile Emacs now fully clothed"))

10
lang/elisp/example.el Normal file
View file

@ -0,0 +1,10 @@
(defun html-page (title &rest contents)
(concat "<HTML>\n"
"<HEAD>\n"
"<TITLE>" title "</TITLE>\n"
"</HEAD>\n"
"<BODY>\n"
(apply 'concat contents)
"</BODY>\n"
"</HTML>\n"))

122
lang/elisp/interface.scm Normal file
View file

@ -0,0 +1,122 @@
(define-module (lang elisp interface)
#:use-module (lang elisp internals evaluation)
#:use-module (lang elisp internals fset)
#:use-module ((lang elisp internals load) #:select ((load . elisp:load)))
#:export (eval-elisp
elisp-function
elisp-variable
load-elisp-file
load-elisp-library
use-elisp-file
use-elisp-library
export-to-elisp
load-emacs))
;;; This file holds my ideas for the mechanisms that would be useful
;;; to exchange definitions between Scheme and Elisp.
(define (eval-elisp x)
"Evaluate the Elisp expression @var{x}."
(eval x the-elisp-module))
(define (elisp-function sym)
"Return the procedure or macro that implements @var{sym} in Elisp.
If @var{sym} has no Elisp function definition, return @code{#f}."
(fref sym))
(define (elisp-variable sym)
"Return the variable that implements @var{sym} in Elisp.
If @var{sym} has no Elisp variable definition, return @code{#f}."
(module-variable the-elisp-module sym))
(define (load-elisp-file file-name)
"Load @var{file-name} into the Elisp environment.
@var{file-name} is assumed to name a file containing Elisp code."
;; This is the same as Elisp's `load-file', so use that if it is
;; available, otherwise duplicate the definition of `load-file' from
;; files.el.
(let ((load-file (elisp-function 'load-file)))
(if load-file
(load-file file-name)
(elisp:load file-name #f #f #t))))
(define (load-elisp-library library)
"Load library @var{library} into the Elisp environment.
@var{library} should name an Elisp code library that can be found in
one of the directories of @code{load-path}."
;; This is the same as Elisp's `load-file', so use that if it is
;; available, otherwise duplicate the definition of `load-file' from
;; files.el.
(let ((load-library (elisp-function 'load-library)))
(if load-library
(load-library library)
(elisp:load library))))
(define export-module-name
(let ((counter 0))
(lambda ()
(set! counter (+ counter 1))
(list 'lang 'elisp
(string->symbol (string-append "imports:"
(number->string counter)))))))
(define-macro (use-elisp-file file-name . imports)
"Load Elisp code file @var{file-name} and import its definitions
into the current Scheme module. If any @var{imports} are specified,
they are interpreted as selection and renaming specifiers as per
@code{use-modules}."
(let ((export-module-name (export-module-name)))
`(begin
(fluid-set! ,elisp-export-module (resolve-module ',export-module-name))
(beautify-user-module! (resolve-module ',export-module-name))
(load-elisp-file ,file-name)
(use-modules (,export-module-name ,@imports))
(fluid-set! ,elisp-export-module #f))))
(define-macro (use-elisp-library library . imports)
"Load Elisp library @var{library} and import its definitions into
the current Scheme module. If any @var{imports} are specified, they
are interpreted as selection and renaming specifiers as per
@code{use-modules}."
(let ((export-module-name (export-module-name)))
`(begin
(fluid-set! ,elisp-export-module (resolve-module ',export-module-name))
(beautify-user-module! (resolve-module ',export-module-name))
(load-elisp-library ,library)
(use-modules (,export-module-name ,@imports))
(fluid-set! ,elisp-export-module #f))))
(define (export-to-elisp . defs)
"Export procedures and variables specified by @var{defs} to Elisp.
Each @var{def} is either an object, in which case that object must be
a named procedure or macro and is exported to Elisp under its Scheme
name; or a symbol, in which case the variable named by that symbol is
exported under its Scheme name; or a pair @var{(obj . name)}, in which
case @var{obj} must be a procedure, macro or symbol as already
described and @var{name} specifies the name under which that object is
exported to Elisp."
(for-each (lambda (def)
(let ((obj (if (pair? def) (car def) def))
(name (if (pair? def) (cdr def) #f)))
(cond ((procedure? obj)
(or name
(set! name (procedure-name obj)))
(if name
(fset name obj)
(error "No procedure name specified or deducible:" obj)))
((macro? obj)
(or name
(set! name (macro-name obj)))
(if name
(fset name obj)
(error "No macro name specified or deducible:" obj)))
((symbol? obj)
(or name
(set! name symbol))
(module-add! the-elisp-module name
(module-ref (current-module) obj)))
(else
(error "Can't export this kind of object to Elisp:" obj)))))
defs))
(define load-emacs (elisp-function 'load-emacs))

2
lang/elisp/internals/.cvsignore Normal file
View file

@ -0,0 +1,2 @@
Makefile
Makefile.in

41
lang/elisp/internals/Makefile.am Normal file
View file

@ -0,0 +1,41 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as
## published by the Free Software Foundation; either version 2, or
## (at your option) any later version.
##
## GUILE 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 GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
AUTOMAKE_OPTIONS = gnu
# These should be installed and distributed.
elisp_sources = \
evaluation.scm \
format.scm \
fset.scm \
load.scm \
null.scm \
set.scm \
signal.scm \
time.scm \
trace.scm
subpkgdatadir = $(pkgdatadir)/$(VERSION)/lang/elisp/internals
subpkgdata_DATA = $(elisp_sources)
ETAGS_ARGS = $(subpkgdata_DATA)
EXTRA_DIST = $(elisp_sources)

13
lang/elisp/internals/evaluation.scm Normal file
View file

@ -0,0 +1,13 @@
(define-module (lang elisp internals evaluation)
#:export (the-elisp-module))
;;;; {Elisp Evaluation}
;;;; All elisp evaluation happens within the same module - namely
;;;; (lang elisp base). This is necessary both because elisp itself
;;;; has no concept of different modules - reflected for example in
;;;; its single argument `eval' function - and because Guile's current
;;;; implementation of elisp stores elisp function definitions in
;;;; slots in global symbol objects.
(define the-elisp-module (resolve-module '(lang elisp base)))

62
lang/elisp/internals/format.scm Normal file
View file

@ -0,0 +1,62 @@
(define-module (lang elisp internals format)
#:pure
#:use-module (ice-9 r5rs)
#:use-module ((ice-9 format) #:select ((format . scheme:format)))
#:use-module (lang elisp internals fset)
#:use-module (lang elisp internals signal)
#:export (format
message))
(define (format control-string . args)
(define (cons-string str ls)
(let loop ((sl (string->list str))
(ls ls))
(if (null? sl)
ls
(loop (cdr sl) (cons (car sl) ls)))))
(let loop ((input (string->list control-string))
(args args)
(output '())
(mid-control #f))
(if (null? input)
(if mid-control
(error "Format string ends in middle of format specifier")
(list->string (reverse output)))
(if mid-control
(case (car input)
((#\%)
(loop (cdr input)
args
(cons #\% output)
#f))
(else
(loop (cdr input)
(cdr args)
(cons-string (case (car input)
((#\s) (scheme:format #f "~A" (car args)))
((#\d) (number->string (car args)))
((#\o) (number->string (car args) 8))
((#\x) (number->string (car args) 16))
((#\e) (number->string (car args))) ;FIXME
((#\f) (number->string (car args))) ;FIXME
((#\g) (number->string (car args))) ;FIXME
((#\c) (let ((a (car args)))
(if (char? a)
(string a)
(string (integer->char a)))))
((#\S) (scheme:format #f "~S" (car args)))
(else
(error "Invalid format operation %%%c" (car input))))
output)
#f)))
(case (car input)
((#\%)
(loop (cdr input) args output #t))
(else
(loop (cdr input) args (cons (car input) output) #f)))))))
(define (message control-string . args)
(display (apply format control-string args))
(newline))

111
lang/elisp/internals/fset.scm Normal file
View file

@ -0,0 +1,111 @@
(define-module (lang elisp internals fset)
#:use-module (lang elisp internals signal)
#:use-module (lang elisp internals evaluation)
#:export (fset
fref
fref/error-if-void
elisp-apply
interactive-specification
not-subr?
elisp-export-module))
(define the-variables-module (resolve-module '(lang elisp variables)))
;; By default, Guile GC's unreachable symbols. So we need to make
;; sure they stay reachable!
(define syms '())
;; elisp-export-module, if non-#f, holds a module to which definitions
;; should be exported under their normal symbol names. This is used
;; when importing Elisp definitions into Scheme.
(define elisp-export-module (make-fluid))
;; Store the procedure, macro or alias symbol PROC in SYM's function
;; slot.
(define (fset sym proc)
(or (memq sym syms)
(set! syms (cons sym syms)))
(let ((vcell (symbol-fref sym))
(vsym #f)
(export-module (fluid-ref elisp-export-module)))
;; Playing around with variables and name properties... For the
;; reasoning behind this, see the commentary in (lang elisp
;; variables).
(cond ((procedure? proc)
;; A procedure created from Elisp will already have a name
;; property attached, with value of the form
;; <elisp-defun:NAME> or <elisp-lambda>. Any other
;; procedure coming through here must be an Elisp primitive
;; definition, so we give it a name of the form
;; <elisp-subr:NAME>.
(or (procedure-name proc)
(set-procedure-property! proc
'name
(symbol-append '<elisp-subr: sym '>)))
(set! vsym (procedure-name proc)))
((macro? proc)
;; Macros coming through here must be defmacros, as all
;; primitive special forms are handled directly by the
;; transformer.
(set-procedure-property! (macro-transformer proc)
'name
(symbol-append '<elisp-defmacro: sym '>))
(set! vsym (procedure-name (macro-transformer proc))))
(else
;; An alias symbol.
(set! vsym (symbol-append '<elisp-defalias: sym '>))))
;; This is the important bit!
(if (variable? vcell)
(variable-set! vcell proc)
(begin
(set! vcell (make-variable proc))
(symbol-fset! sym vcell)
;; Playing with names and variables again - see above.
(module-add! the-variables-module vsym vcell)
(module-export! the-variables-module (list vsym))))
;; Export variable to the export module, if non-#f.
(if (and export-module
(or (procedure? proc)
(macro? proc)))
(begin
(module-add! export-module sym vcell)
(module-export! export-module (list sym))))))
;; Retrieve the procedure or macro stored in SYM's function slot.
;; Note the asymmetry w.r.t. fset: if fref finds an alias symbol, it
;; recursively calls fref on that symbol. Returns #f if SYM's
;; function slot doesn't contain a valid definition.
(define (fref sym)
(let ((var (symbol-fref sym)))
(if (and var (variable? var))
(let ((proc (variable-ref var)))
(cond ((symbol? proc)
(fref proc))
(else
proc)))
#f)))
;; Same as fref, but signals an Elisp error if SYM's function
;; definition is void.
(define (fref/error-if-void sym)
(or (fref sym)
(signal 'void-function (list sym))))
;; Maps a procedure to its (interactive ...) spec.
(define interactive-specification (make-object-property))
;; Maps a procedure to #t if it is NOT a built-in.
(define not-subr? (make-object-property))
(define (elisp-apply function . args)
(apply apply
(cond ((symbol? function)
(fref/error-if-void function))
((procedure? function)
function)
((and (pair? function)
(eq? (car function) 'lambda))
(eval function the-elisp-module))
(else
(signal 'invalid-function (list function))))
args))

45
lang/elisp/internals/load.scm Normal file
View file

@ -0,0 +1,45 @@
(define-module (lang elisp internals load)
#:use-module (ice-9 optargs)
#:use-module (lang elisp internals signal)
#:use-module (lang elisp internals format)
#:use-module (lang elisp internals evaluation)
#:export (load-path
load))
(define load-path '("/usr/share/emacs/20.7/lisp/"
"/usr/share/emacs/20.7/lisp/emacs-lisp/"))
(define* (load file #:optional noerror nomessage nosuffix must-suffix)
(define (load1 filename)
(let ((pathname (let loop ((dirs (if (char=? (string-ref filename 0) #\/)
'("")
load-path)))
(cond ((null? dirs) #f)
((file-exists? (string-append (car dirs)
filename))
(string-append (car dirs) filename))
(else (loop (cdr dirs)))))))
(if pathname
(begin
(or nomessage
(message "Loading %s..." pathname))
(with-input-from-file pathname
(lambda ()
(let loop ((form (read)))
(or (eof-object? form)
(begin
;; Note that `eval' already incorporates use
;; of the specified module's transformer.
(eval form the-elisp-module)
(loop (read)))))))
(or nomessage
(message "Loading %s...done" pathname))
#t)
#f)))
(or (and (not nosuffix)
(load1 (string-append file ".el")))
(and (not must-suffix)
(load1 file))
noerror
(signal 'file-error
(list "Cannot open load file" file))))

6
lang/elisp/internals/null.scm Normal file
View file

@ -0,0 +1,6 @@
(define-module (lang elisp internals null)
#:export (null))
(define (null obj)
(or (not obj)
(null? obj)))

9
lang/elisp/internals/set.scm Normal file
View file

@ -0,0 +1,9 @@
(define-module (lang elisp internals set)
#:use-module (lang elisp internals evaluation)
#:use-module (lang elisp internals signal)
#:export (set))
;; Set SYM's variable value to VAL, and return VAL.
(define (set sym val)
(module-define! the-elisp-module sym val)
val)

18
lang/elisp/internals/signal.scm Normal file
View file

@ -0,0 +1,18 @@
(define-module (lang elisp internals signal)
#:use-module (lang elisp internals format)
#:export (signal
error
wta))
(define (signal error-symbol data)
(scm-error 'elisp-signal
#f
"Signalling ~A with data ~S"
(list error-symbol data)
#f))
(define (error . args)
(signal 'error (list (apply format args))))
(define (wta expected actual pos)
(signal 'wrong-type-argument (list expected actual)))

14
lang/elisp/internals/time.scm Normal file
View file

@ -0,0 +1,14 @@
(define-module (lang elisp internals time)
#:use-module (ice-9 optargs)
#:export (format-time-string))
(define* (format-time-string format-string #:optional time universal)
(strftime format-string
((if universal gmtime localtime)
(if time
(+ (ash (car time) 16)
(let ((time-cdr (cdr time)))
(if (pair? time-cdr)
(car time-cdr)
time-cdr)))
(current-time)))))

28
lang/elisp/internals/trace.scm Normal file
View file

@ -0,0 +1,28 @@
(define-module (lang elisp internals trace)
#:export (trc trc-syms trc-all trc-none))
(define *syms* #f)
(define (trc-syms . syms)
(set! *syms* syms))
(define (trc-all)
(set! *syms* #f))
(define (trc-none)
(set! *syms* '()))
(define (trc . args)
(let ((sym (car args))
(args (cdr args)))
(if (or (and *syms*
(memq sym *syms*))
(not *syms*))
(begin
(write sym)
(display ": ")
(write args)
(newline)))))
;; Default to no tracing.
(trc-none)

2
lang/elisp/primitives/.cvsignore Normal file
View file

@ -0,0 +1,2 @@
Makefile
Makefile.in

49
lang/elisp/primitives/Makefile.am Normal file
View file

@ -0,0 +1,49 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as
## published by the Free Software Foundation; either version 2, or
## (at your option) any later version.
##
## GUILE 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 GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
AUTOMAKE_OPTIONS = gnu
# These should be installed and distributed.
elisp_sources = \
buffers.scm \
features.scm \
fns.scm \
format.scm \
guile.scm \
keymaps.scm \
lists.scm \
load.scm \
match.scm \
numbers.scm \
pure.scm \
read.scm \
signal.scm \
strings.scm \
symprop.scm \
system.scm \
time.scm
subpkgdatadir = $(pkgdatadir)/$(VERSION)/lang/elisp/primitives
subpkgdata_DATA = $(elisp_sources)
ETAGS_ARGS = $(subpkgdata_DATA)
EXTRA_DIST = $(elisp_sources)

16
lang/elisp/primitives/buffers.scm Normal file
View file

@ -0,0 +1,16 @@
(define-module (lang elisp primitives buffers)
#:use-module (ice-9 optargs)
#:use-module (lang elisp internals fset))
(fset 'buffer-disable-undo
(lambda* (#:optional buffer)
'unimplemented))
(fset 're-search-forward
(lambda* (regexp #:optional bound noerror count)
'unimplemented))
(fset 're-search-backward
(lambda* (regexp #:optional bound noerror count)
'unimplemented))

25
lang/elisp/primitives/features.scm Normal file
View file

@ -0,0 +1,25 @@
(define-module (lang elisp primitives features)
#:use-module (lang elisp internals fset)
#:use-module (lang elisp internals load)
#:use-module (ice-9 optargs))
(define-public features '())
(fset 'provide
(lambda (feature)
(or (memq feature features)
(set! features (cons feature features)))))
(fset 'featurep
(lambda (feature)
(memq feature features)))
(fset 'require
(lambda* (feature #:optional file-name noerror)
(or (memq feature features)
(load (or file-name
(symbol->string feature))
noerror
#f
#f
#t))))

45
lang/elisp/primitives/fns.scm Normal file
View file

@ -0,0 +1,45 @@
(define-module (lang elisp primitives fns)
#:use-module (lang elisp internals fset))
(fset 'fset fset)
(fset 'defalias fset)
(fset 'apply elisp-apply)
(fset 'funcall
(lambda (function . args)
(elisp-apply function args)))
(fset 'interactive-p
(lambda ()
#f))
(fset 'commandp
(lambda (sym)
(if (interactive-spec (fref sym)) #t #f)))
(fset 'fboundp
(lambda (sym)
(variable? (symbol-fref sym))))
(fset 'symbol-function fref/error-if-void)
(fset 'macroexpand macroexpand)
(fset 'subrp
(lambda (obj)
(not (not-subr? obj))))
(fset 'byte-code-function-p
(lambda (object)
#f))
(fset 'run-hooks
(lambda (hooks)
(cond ((null hooks))
((list? hooks)
(for-each (lambda (hook)
(elisp-apply hook '()))
hooks))
(else
(elisp-apply hooks '())))))

6
lang/elisp/primitives/format.scm Normal file
View file

@ -0,0 +1,6 @@
(define-module (lang elisp primitives format)
#:use-module (lang elisp internals format)
#:use-module (lang elisp internals fset))
(fset 'format format)
(fset 'message message)

20
lang/elisp/primitives/guile.scm Normal file
View file

@ -0,0 +1,20 @@
(define-module (lang elisp primitives guile)
#:use-module (lang elisp internals fset))
;;; {Importing Guile procedures into Elisp}
;; It may be worthwhile to import some Guile procedures into the Elisp
;; environment. For now, though, we don't do this.
(if #f
(let ((accessible-procedures
(apropos-fold (lambda (module name var data)
(cons (cons name var) data))
'()
""
(apropos-fold-accessible (current-module)))))
(for-each (lambda (name var)
(if (procedure? var)
(fset name var)))
(map car accessible-procedures)
(map cdr accessible-procedures))))

26
lang/elisp/primitives/keymaps.scm Normal file
View file

@ -0,0 +1,26 @@
(define-module (lang elisp primitives keymaps)
#:use-module (lang elisp internals fset))
(define (make-sparse-keymap)
(list 'keymap))
(define (define-key keymap key def)
(set-cdr! keymap
(cons (cons key def) (cdr keymap))))
(define global-map (make-sparse-keymap))
(define esc-map (make-sparse-keymap))
(define ctl-x-map (make-sparse-keymap))
(define ctl-x-4-map (make-sparse-keymap))
(define ctl-x-5-map (make-sparse-keymap))
;;; {Elisp Exports}
(fset 'make-sparse-keymap make-sparse-keymap)
(fset 'define-key define-key)
(export global-map
esc-map
ctl-x-map
ctl-x-4-map
ctl-x-5-map)

108
lang/elisp/primitives/lists.scm Normal file
View file

@ -0,0 +1,108 @@
(define-module (lang elisp primitives lists)
#:use-module (lang elisp internals fset)
#:use-module (lang elisp internals null)
#:use-module (lang elisp internals signal))
(fset 'cons
(lambda (x y)
(cons x (or y '()))))
(fset 'null null)
(fset 'not null)
(fset 'car
(lambda (l)
(if (null l)
#f
(car l))))
(fset 'cdr
(lambda (l)
(if (null l)
#f
(cdr l))))
(fset 'eq
(lambda (x y)
(or (eq? x y)
(and (null x) (null y)))))
(fset 'equal
(lambda (x y)
(or (equal? x y)
(and (null x) (null y)))))
(fset 'setcar set-car!)
(fset 'setcdr
(lambda (cell newcdr)
(set-cdr! cell
(if (null newcdr)
'()
newcdr))))
(for-each (lambda (sym proc)
(fset sym
(lambda (elt list)
(if (null list)
#f
(if (null elt)
(or (proc #f list)
(proc '() list))
(proc elt list))))))
'( memq member assq assoc)
`(,memq ,member ,assq ,assoc))
(fset 'length
(lambda (x)
(cond ((null x) 0)
((pair? x) (length x))
((vector? x) (vector-length x))
((string? x) (string-length x))
(else (wta 'sequencep x 1)))))
(fset 'copy-sequence
(lambda (x)
(cond ((list? x) (list-copy x))
((vector? x) (error "Vector copy not yet implemented"))
((string? x) (string-copy x))
(else (wta 'sequencep x 1)))))
(fset 'elt
(lambda (obj i)
(cond ((pair? obj) (list-ref obj i))
((vector? obj) (vector-ref obj i))
((string? obj) (char->integer (string-ref obj i))))))
(fset 'list list)
(fset 'mapcar
(lambda (function sequence)
(map (lambda (elt)
(elisp-apply function (list elt)))
(cond ((null sequence) '())
((list? sequence) sequence)
((vector? sequence) (vector->list sequence))
((string? sequence) (map char->integer (string->list sequence)))
(else (wta 'sequencep sequence 2))))))
(fset 'nth
(lambda (n list)
(if (or (null list)
(>= n (length list)))
#f
(list-ref list n))))
(fset 'listp
(lambda (object)
(or (null object)
(list? object))))
(fset 'consp pair?)
(fset 'nconc
(lambda args
(apply append! (map (lambda (arg)
(if arg arg '()))
args))))

17
lang/elisp/primitives/load.scm Normal file
View file

@ -0,0 +1,17 @@
(define-module (lang elisp primitives load)
#:use-module (lang elisp internals load)
#:use-module (lang elisp internals evaluation)
#:use-module (lang elisp internals fset))
(fset 'load load)
(re-export load-path)
(fset 'eval
(lambda (form)
(eval form the-elisp-module)))
(fset 'autoload
(lambda args
#t))
(define-public current-load-list #f)

68
lang/elisp/primitives/match.scm Normal file
View file

@ -0,0 +1,68 @@
(define-module (lang elisp primitives match)
#:use-module (lang elisp internals fset)
#:use-module (ice-9 regex)
#:use-module (ice-9 optargs))
(define last-match #f)
(fset 'string-match
(lambda (regexp string . start)
(define emacs-string-match
(if (defined? 'make-emacs-regexp)
;; This is what we would do if we had an
;; Emacs-compatible regexp primitive, here called
;; `make-emacs-regexp'.
(lambda (pattern str . args)
(let ((rx (make-emacs-regexp pattern))
(start (if (pair? args) (car args) 0)))
(regexp-exec rx str start)))
;; But we don't have Emacs-compatible regexps, and I
;; don't think it's worthwhile at this stage to write
;; generic regexp conversion code. So work around the
;; discrepancies between Guile/libc and Emacs regexps by
;; substituting the regexps that actually occur in the
;; elisp code that we want to read.
(lambda (pattern str . args)
(let loop ((discrepancies '(("^[0-9]+\\.\\([0-9]+\\)" .
"^[0-9]+\\.([0-9]+)"))))
(or (null? discrepancies)
(if (string=? pattern (caar discrepancies))
(set! pattern (cdar discrepancies))
(loop (cdr discrepancies)))))
(apply string-match pattern str args))))
(let ((match (apply emacs-string-match regexp string start)))
(set! last-match
(if match
(apply append!
(map (lambda (n)
(list (match:start match n)
(match:end match n)))
(iota (match:count match))))
#f)))
(if last-match (car last-match) #f)))
(fset 'match-beginning
(lambda (subexp)
(list-ref last-match (* 2 subexp))))
(fset 'match-end
(lambda (subexp)
(list-ref last-match (+ (* 2 subexp) 1))))
(fset 'substring substring)
(fset 'match-data
(lambda* (#:optional integers reuse)
last-match))
(fset 'set-match-data
(lambda (list)
(set! last-match list)))
(fset 'store-match-data 'set-match-data)

42
lang/elisp/primitives/numbers.scm Normal file
View file

@ -0,0 +1,42 @@
(define-module (lang elisp primitives numbers)
#:use-module (lang elisp internals fset))
(fset 'logior logior)
(fset 'logand logand)
(fset 'integerp integer?)
(fset '= =)
(fset '< <)
(fset '> >)
(fset '<= <=)
(fset '>= >=)
(fset '* *)
(fset '+ +)
(fset '- -)
(fset '1- 1-)
(fset 'ash ash)
(fset 'lsh
(let ()
(define (lsh num shift)
(cond ((= shift 0)
num)
((< shift 0)
;; Logical shift to the right. Do an arithmetic
;; shift and then mask out the sign bit.
(lsh (logand (ash num -1) most-positive-fixnum)
(+ shift 1)))
(else
;; Logical shift to the left. Guile's ash will
;; always preserve the sign of the result, which is
;; not what we want for lsh, so we need to work
;; around this.
(let ((new-sign-bit (ash (logand num
(logxor most-positive-fixnum
(ash most-positive-fixnum -1)))
1)))
(lsh (logxor new-sign-bit
(ash (logand num most-positive-fixnum) 1))
(- shift 1))))))
lsh))
(fset 'numberp number?)

8
lang/elisp/primitives/pure.scm Normal file
View file

@ -0,0 +1,8 @@
(define-module (lang elisp primitives pure)
#:use-module (lang elisp internals fset))
;; Purification, unexec etc. are not yet implemented...
(fset 'purecopy identity)
(define-public purify-flag #f)

10
lang/elisp/primitives/read.scm Normal file
View file

@ -0,0 +1,10 @@
(define-module (lang elisp primitives read)
#:use-module (lang elisp internals fset))
;;; MEGA HACK!!!!
(fset 'read (lambda (str)
(cond ((string=? str "?\\M-\\^@")
-134217728)
(else
(with-input-from-string str read)))))

6
lang/elisp/primitives/signal.scm Normal file
View file

@ -0,0 +1,6 @@
(define-module (lang elisp primitives signal)
#:use-module (lang elisp internals signal)
#:use-module (lang elisp internals fset))
(fset 'signal signal)
(fset 'error error)

31
lang/elisp/primitives/strings.scm Normal file
View file

@ -0,0 +1,31 @@
(define-module (lang elisp primitives strings)
#:use-module (lang elisp internals fset)
#:use-module (lang elisp internals signal))
(fset 'substring substring)
(fset 'concat
(lambda args
(apply string-append
(map (lambda (arg)
(cond
((string? arg) arg)
((list? arg) (list->string arg))
((vector? arg) (list->string (vector->list arg)))
(else (error "Wrong type argument for concat"))))
args))))
(fset 'string-to-number string->number)
(fset 'number-to-string number->string)
(fset 'string-lessp string<?)
(fset 'string< 'string-lessp)
(fset 'aref
(lambda (array idx)
(cond ((vector? array) (vector-ref array idx))
((string? array) (char->integer (string-ref array idx)))
(else (wta 'arrayp array 1)))))
(fset 'stringp string?)

40
lang/elisp/primitives/symprop.scm Normal file
View file

@ -0,0 +1,40 @@
(define-module (lang elisp primitives symprop)
#:use-module (lang elisp internals set)
#:use-module (lang elisp internals fset)
#:use-module (lang elisp internals evaluation)
#:use-module (ice-9 optargs))
;;; {Elisp Exports}
(fset 'put set-symbol-property!)
(fset 'get symbol-property)
(fset 'set set)
(fset 'set-default 'set)
(fset 'boundp
(lambda (sym)
(module-defined? the-elisp-module sym)))
(fset 'default-boundp 'boundp)
(fset 'symbol-value
(lambda (sym)
(if (module-defined? the-elisp-module sym)
(module-ref the-elisp-module sym)
(error "Symbol's value as variable is void:" sym))))
(fset 'default-value 'symbol-value)
(fset 'symbolp
(lambda (object)
(or (symbol? object)
(keyword? object))))
(fset 'local-variable-if-set-p
(lambda* (variable #:optional buffer)
#f))
(fset 'symbol-name symbol->string)

14
lang/elisp/primitives/system.scm Normal file
View file

@ -0,0 +1,14 @@
(define-module (lang elisp primitives system)
#:use-module (lang elisp internals fset))
(fset 'system-name
(lambda ()
(vector-ref (uname) 1)))
(define-public system-type
(let ((uname (vector-ref (uname) 0)))
(if (string=? uname "Linux")
"gnu/linux"
uname)))
(define-public system-configuration "i386-suse-linux") ;FIXME

17
lang/elisp/primitives/time.scm Normal file
View file

@ -0,0 +1,17 @@
(define-module (lang elisp primitives time)
#:use-module (lang elisp internals time)
#:use-module (lang elisp internals fset)
#:use-module (ice-9 optargs))
(fset 'current-time
(lambda ()
(let ((now (current-time)))
(list (ash now -16)
(logand now (- (ash 1 16) 1))
0))))
(fset 'format-time-string format-time-string)
(fset 'current-time-string
(lambda* (#:optional specified-time)
(format-time-string "%a %b %e %T %Y" specified-time)))

414
lang/elisp/transform.scm Normal file
View file

@ -0,0 +1,414 @@
(define-module (lang elisp transform)
#:use-module (lang elisp internals trace)
#:use-module (lang elisp internals fset)
#:use-module (lang elisp internals evaluation)
#:use-module (ice-9 session)
#:export (transformer))
(define interactive-spec (make-fluid))
;;; {S-expressions}
;;;
(define (syntax-error x)
(error "Syntax error in expression" x))
;; Should be made mutating instead of constructing
;;
(define (transformer x)
(cond ((null? x) '())
((not (pair? x)) x)
((and (pair? (car x))
(eq? (caar x) 'quasiquote))
(transformer (car x)))
((symbol? (car x))
(case (car x)
((@fop @bind define-module use-modules use-syntax) x)
; Escape to Scheme syntax
((scheme) (cons 'begin (cdr x)))
; Should be handled in reader
((quote function) (cons 'quote (cars->nil (cdr x))))
((quasiquote) (m-quasiquote x '()))
((nil-cond) (transform-1 x))
((let) (m-let x '()))
((let*) (m-let* x '()))
((if) (m-if x '()))
((and) (m-and x '()))
((or) (m-or x '()))
((while) (m-while x '()))
;((while) (cons macro-while (cdr x)))
((prog1) (m-prog1 x '()))
((prog2) (m-prog2 x '()))
((progn begin) (cons 'begin (map transformer (cdr x))))
((cond) (m-cond x '()))
((lambda) (transform-lambda/interactive x '<elisp-lambda>))
((defun) (m-defun x '()))
((defmacro) (m-defmacro x '()))
((setq) (m-setq x '()))
((defvar) (m-defvar x '()))
((defconst) (m-defconst x '()))
((interactive) (fluid-set! interactive-spec x) #f)
((unwind-protect) (m-unwind-protect x '()))
(else (transform-application x))))
(else (syntax-error x))))
(define (m-unwind-protect exp env)
(trc 'unwind-protect (cadr exp))
`(let ((%--throw-args #f))
(catch #t
(lambda ()
,(transformer (cadr exp)))
(lambda args
(set! %--throw-args args)))
,@(transform-list (cddr exp))
(if %--throw-args
(apply throw %--throw-args))))
(define (m-quasiquote exp env)
(cons 'quasiquote
(map transform-inside-qq (cdr exp))))
(define (transform-inside-qq x)
(trc 'transform-inside-qq x)
(cond ((not (pair? x)) x)
((symbol? (car x))
(case (car x)
((unquote) (list 'unquote (transformer (cadr x))))
((unquote-splicing) (list 'unquote-splicing (transformer (cadr x))))
(else (cons (car x) (map transform-inside-qq (cdr x))))))
(else
(cons (transform-inside-qq (car x)) (transform-inside-qq (cdr x))))))
(define (transform-1 x)
(cons (car x) (map transformer (cdr x))))
(define (transform-2 x)
(cons (car x)
(cons (cadr x)
(map transformer (cddr x)))))
(define (transform-3 x)
(cons (car x)
(cons (cadr x)
(cons (caddr x)
(map transformer (cdddr x))))))
(define (transform-list x)
(map transformer x))
;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and
;;; returns three values: (i) list of symbols for required arguments,
;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or
;;; #f if there is no rest argument.
(define (parse-formals formals)
(letrec ((do-required
(lambda (required formals)
(if (null? formals)
(values (reverse required) '() #f)
(let ((next-sym (car formals)))
(cond ((not (symbol? next-sym))
(error "Bad formals (non-symbol in required list)"))
((eq? next-sym '&optional)
(do-optional required '() (cdr formals)))
((eq? next-sym '&rest)
(do-rest required '() (cdr formals)))
(else
(do-required (cons next-sym required)
(cdr formals))))))))
(do-optional
(lambda (required optional formals)
(if (null? formals)
(values (reverse required) (reverse optional) #f)
(let ((next-sym (car formals)))
(cond ((not (symbol? next-sym))
(error "Bad formals (non-symbol in optional list)"))
((eq? next-sym '&rest)
(do-rest required optional (cdr formals)))
(else
(do-optional required
(cons next-sym optional)
(cdr formals))))))))
(do-rest
(lambda (required optional formals)
(if (= (length formals) 1)
(let ((next-sym (car formals)))
(if (symbol? next-sym)
(values (reverse required) (reverse optional) next-sym)
(error "Bad formals (non-symbol rest formal)")))
(error "Bad formals (more than one rest formal)")))))
(do-required '() (cond ((list? formals)
formals)
((symbol? formals)
(list '&rest formals))
(else
(error "Bad formals (not a list or a single symbol)"))))))
(define (transform-lambda/interactive exp name)
(fluid-set! interactive-spec #f)
(let* ((x (transform-lambda exp))
(is (fluid-ref interactive-spec)))
`(let ((%--lambda ,x))
(set-procedure-property! %--lambda 'name ',name)
(set! (,not-subr? %--lambda) #t)
,@(if is
`((set! (,interactive-specification %--lambda) ',is))
'())
%--lambda)))
(define (transform-lambda exp)
(call-with-values (lambda () (parse-formals (cadr exp)))
(lambda (required optional rest)
(let ((num-required (length required))
(num-optional (length optional)))
`(lambda %--args
(let ((%--num-args (length %--args)))
(cond ((< %--num-args ,num-required)
(error "Wrong number of args (not enough required args)"))
,@(if rest
'()
`(((> %--num-args ,(+ num-required num-optional))
(error "Wrong number of args (too many args)"))))
(else
(@bind ,(append (map (lambda (i)
(list (list-ref required i)
`(list-ref %--args ,i)))
(iota num-required))
(map (lambda (i)
(let ((i+nr (+ i num-required)))
(list (list-ref optional i)
`(if (> %--num-args ,i+nr)
(list-ref %--args ,i+nr)
#f))))
(iota num-optional))
(if rest
(list (list rest
`(if (> %--num-args
,(+ num-required
num-optional))
(list-tail %--args
,(+ num-required
num-optional))
'())))
'()))
,@(transform-list (cddr exp)))))))
))))
(define (m-defun exp env)
(trc 'defun (cadr exp))
`(begin (,fset ',(cadr exp)
,(transform-lambda/interactive (cdr exp)
(symbol-append '<elisp-defun:
(cadr exp)
'>)))
',(cadr exp)))
(define (m-defmacro exp env)
(trc 'defmacro (cadr exp))
(call-with-values (lambda () (parse-formals (caddr exp)))
(lambda (required optional rest)
(let ((num-required (length required))
(num-optional (length optional)))
`(begin (,fset ',(cadr exp)
(procedure->memoizing-macro
(lambda (exp1 env1)
(,trc 'using ',(cadr exp))
(let* ((%--args (cdr exp1))
(%--num-args (length %--args)))
(cond ((< %--num-args ,num-required)
(error "Wrong number of args (not enough required args)"))
,@(if rest
'()
`(((> %--num-args ,(+ num-required num-optional))
(error "Wrong number of args (too many args)"))))
(else (,transformer
(@bind ,(append (map (lambda (i)
(list (list-ref required i)
`(list-ref %--args ,i)))
(iota num-required))
(map (lambda (i)
(let ((i+nr (+ i num-required)))
(list (list-ref optional i)
`(if (> %--num-args ,i+nr)
(list-ref %--args ,i+nr)
#f))))
(iota num-optional))
(if rest
(list (list rest
`(if (> %--num-args
,(+ num-required
num-optional))
(list-tail %--args
,(+ num-required
num-optional))
'())))
'()))
,@(transform-list (cdddr exp)))))))))))))))
(define (transform-application x)
`(@fop ,(car x)
(,transformer-macro ,@(cdr x))))
(define transformer-macro
(procedure->memoizing-macro
(lambda (exp env)
(cons 'list (map transformer (cdr exp))))))
; (cons '@fop
; (cons (car x)
; (map transformer (cdr x)))))
(define (cars->nil ls)
(cond ((not (pair? ls)) ls)
((null? (car ls)) (cons '() (cars->nil (cdr ls))))
(else (cons (cars->nil (car ls))
(cars->nil (cdr ls))))))
;;; {Special forms}
;;;
(define (m-setq exp env)
(cons 'begin
(let loop ((sets (cdr exp)) (last-sym #f))
(if (null? sets)
(list last-sym)
(cons `(module-define! ,the-elisp-module
',(car sets)
,(transformer (cadr sets)))
(loop (cddr sets) (car sets)))))))
;(define (m-setq exp env)
; (let* ((binder (car (last-pair env)))
; (varvals (let loop ((ls (cdr exp)))
; (if (null? ls)
; '()
; ;; Ensure existence only at macro expansion time
; (let ((var (or (binder (car ls) #f)
; (binder (car ls) #t))))
; (if (not (variable-bound? var))
; (variable-set! var #f))
; (cons (list 'set! (car ls) (transformer (cadr ls)))
; (loop (cddr ls))))))))
; (cond ((null? varvals) '())
; ((null? (cdr varvals)) (car varvals))
; (else (cons 'begin varvals)))))
(define (m-let exp env)
`(@bind ,(map (lambda (binding)
(trc 'let binding)
(if (pair? binding)
`(,(car binding) ,(transformer (cadr binding)))
`(,binding #f)))
(cadr exp))
,@(transform-list (cddr exp))))
(define (m-let* exp env)
(if (null? (cadr exp))
`(begin ,@(transform-list (cddr exp)))
(car (let loop ((bindings (cadr exp)))
(if (null? bindings)
(transform-list (cddr exp))
`((@bind (,(let ((binding (car bindings)))
(if (pair? binding)
`(,(car binding) ,(transformer (cadr binding)))
`(,binding #f))))
,@(loop (cdr bindings)))))))))
(define (m-prog1 exp env)
`(,let ((%res1 ,(transformer (cadr exp))))
,@(transform-list (cddr exp))
%res1))
(define (m-prog2 exp env)
`(begin ,(transformer (cadr exp))
(,let ((%res2 ,(transformer (caddr exp))))
,@(transform-list (cdddr exp))
%res2)))
(define <-- *unspecified*)
(define (m-if exp env)
(let ((else-case (cdddr exp)))
(cond ((null? else-case)
`(nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) #f))
((null? (cdr else-case))
`(nil-cond ,(transformer (cadr exp))
,(transformer (caddr exp))
,(transformer (car else-case))))
(else
`(nil-cond ,(transformer (cadr exp))
,(transformer (caddr exp))
(begin ,@(transform-list else-case)))))))
(define (m-and exp env)
(cond ((null? (cdr exp)) #t)
((null? (cddr exp)) (transformer (cadr exp)))
(else
(cons 'nil-cond
(let loop ((args (cdr exp)))
(if (null? (cdr args))
(list (transformer (car args)))
(cons (list 'not (transformer (car args)))
(cons #f
(loop (cdr args))))))))))
(define (m-or exp env)
(cond ((null? (cdr exp)) #f)
((null? (cddr exp)) (transformer (cadr exp)))
(else
(cons 'nil-cond
(let loop ((args (cdr exp)))
(if (null? (cdr args))
(list (transformer (car args)))
(cons (transformer (car args))
(cons <--
(loop (cdr args))))))))))
(define m-cond
(lambda (exp env)
(if (null? (cdr exp))
#f
(cons
'nil-cond
(let loop ((clauses (cdr exp)))
(if (null? clauses)
'(#f)
(let ((clause (car clauses)))
(if (eq? (car clause) #t)
(cond ((null? (cdr clause)) '(t))
((null? (cddr clause))
(list (transformer (cadr clause))))
(else `((begin ,@(transform-list (cdr clause))))))
(cons (transformer (car clause))
(cons (cond ((null? (cdr clause)) <--)
((null? (cddr clause))
(transformer (cadr clause)))
(else
`(begin ,@(transform-list (cdr clause)))))
(loop (cdr clauses))))))))))))
(define (m-while exp env)
`(,let %while ()
(nil-cond ,(transformer (cadr exp))
(begin ,@(transform-list (cddr exp)) (%while))
#f)))
(define (m-defvar exp env)
(trc 'defvar (cadr exp))
(if (null? (cddr exp))
`',(cadr exp)
`(begin (if (not (defined? ',(cadr exp)))
(,macro-setq ,(cadr exp) ,(caddr exp)))
',(cadr exp))))
(define (m-defconst exp env)
(trc 'defconst (cadr exp))
`(begin ,(m-setq (list (car exp) (cadr exp) (caddr exp)) env)
',(cadr exp)))
;(export-mmacros
; '(setq defun let let* if and or cond while prog1 prog2 progn)
; (list m-setq m-defun m-let m-let* m-if m-and m-or m-cond m-while m-prog1 m-prog2 begin))
(define macro-setq (procedure->memoizing-macro m-setq))
(define macro-while (procedure->memoizing-macro m-while))

42
lang/elisp/variables.scm Normal file
View file

@ -0,0 +1,42 @@
(define-module (lang elisp variables))
;;; The only purpose of this module is to provide a place where the
;;; variables holding Elisp function definitions can be bound to
;;; symbols.
;;;
;;; This can be useful when looking at unmemoized procedure source
;;; code for Elisp functions and macros. Elisp function and macro
;;; symbols get memoized into variables. When the unmemoizer tries to
;;; unmemoize a variables, it does so by looking for a symbol that is
;;; bound to that variable, starting from the module in which the
;;; function or macro was defined and then trying the interfaces on
;;; that module's uses list. If it can't find any such symbol, it
;;; returns the symbol '???.
;;;
;;; Normally we don't want to bind Elisp function definition variables
;;; to symbols that are visible from the Elisp evaluation module (lang
;;; elisp base), because they would pollute the namespace available
;;; to Elisp variables. On the other hand, if we are trying to debug
;;; something, and looking at unmemoized source code, it's far more
;;; informative if that code has symbols that indicate the Elisp
;;; function being called than if it just says ??? everywhere.
;;;
;;; So we have a compromise, which achieves a reasonable balance of
;;; correctness (for general operation) and convenience (for
;;; debugging).
;;;
;;; 1. We bind Elisp function definition variables to symbols in this
;;; module (lang elisp variables).
;;;
;;; 2. By default, the Elisp evaluation module (lang elisp base) does
;;; not use (lang elisp variables), so the Elisp variable namespace
;;; stays clean.
;;;
;;; 3. When debugging, a simple (named-module-use! '(lang elisp base)
;;; '(lang elisp variables)) makes the function definition symbols
;;; visible in (lang elisp base) so that the unmemoizer can find
;;; them, which makes the unmemoized source code much easier to read.
;;;
;;; 4. To reduce the effects of namespace pollution even after step 3,
;;; the symbols that we bind are all prefixed with `<elisp' and
;;; suffixed with `>'.

1
test-suite/Makefile.am
View file

@ -5,6 +5,7 @@ SCM_TESTS = tests/alist.test \
tests/c-api.test \ tests/c-api.test \
tests/chars.test \ tests/chars.test \
tests/common-list.test \ tests/common-list.test \
tests/elisp.test \
tests/environments.test \ tests/environments.test \
tests/eval.test \ tests/eval.test \
tests/exceptions.test \ tests/exceptions.test \