[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-168-gc
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-168-gc6920dc |
|
Date: |
Tue, 07 Dec 2010 12:49:34 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=c6920dc8bae4546ffeb250570d7abc8ace9ce91c
The branch, master has been updated
via c6920dc8bae4546ffeb250570d7abc8ace9ce91c (commit)
via 3f70b2dc5c33073b6f24078bc1fc1d6bdcd3b03f (commit)
via 67cb2c27610295aa68445951c03a7550efc9453a (commit)
via b41a673d2647eef7ff43469ed864bd584fcd9be2 (commit)
via b7966c10efaaaf95e3a6fe300e79d9c3c195bde5 (commit)
via f5742cf042fbcdb9b8319a6b96fd32b03dcb42ca (commit)
via 0dbfdeefc6de02224892d6775aa0b64ade0f0a12 (commit)
via 44ae163d2c469c62352cbce7dbb3542b421a2f8d (commit)
via e9de35293f237081365879e1e637267b5eb058b6 (commit)
via 2ce5e74073519c7056c10239dc42de435f2e5bf8 (commit)
via 65b46b72417c375a212bb5e2bf8b833870c0269d (commit)
via 9efe5b230db733c491aabf3c5c424ee01a6a420c (commit)
via 382991966332a67caf30b6ec00f39d74b2e4ae02 (commit)
via 1dfe593954b094bfd25738f1553baa3a557476a9 (commit)
via 8295b7c4e5637d363649101fa5080f9d31b80c14 (commit)
via 6e9ebc9179af52e90402ddd0b7f10f3857a0d329 (commit)
via eda83f0ac98ba3ba5655aa251ce8c5b4def70b34 (commit)
via 450cb50419e6c203cb5b550d7bab925532921730 (commit)
via f4e5e4114dad35276355470aa4096af3ec0b7d1c (commit)
via c983a199d8a941d7183e10b7a1d1ecb2e3ede837 (commit)
via abcf4a9e1dc06607ddb43861e33a982e36ffac4b (commit)
via 9c933e1d3f72d9d8693e030c24de44adc9f9e0b9 (commit)
via a8aa4c0b56624dc77b71d6b4892f6b14ad9e751d (commit)
via ef94624eaf549ca9c730d4650b9dfed2ee48521b (commit)
via d1079217947013dac495a95e433ad5da9f7aa80a (commit)
via 1f845305c184814e253f0c4ac5a2aaac874b20a2 (commit)
from 4431a337f021b0d45886cbc93698aaaa5d05b764 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit c6920dc8bae4546ffeb250570d7abc8ace9ce91c
Author: Brian Templeton <address@hidden>
Date: Mon Aug 16 03:20:55 2010 -0400
lexical function binding for elisp
* module/language/elisp/compile-tree-il.scm (access-variable)
(reference-variable, set-variable!): Handle globally-bound non-special
variables.
(bind-lexically?): Create lexical bindings for flet and flet*.
* module/language/elisp/runtime.scm (reference-variable, set-variable!):
Handle globally-bound non-special variables.
(built-in-func): Set the variable directly instead of storing the
function in a fluid.
* module/language/elisp/runtime/subrs.scm (funcall): Call apply
directly.
* test-suite/tests/elisp-compiler.test ("Function Definitions")["flet
and flet*"]:
Signed-off-by: Andy Wingo <address@hidden>
commit 3f70b2dc5c33073b6f24078bc1fc1d6bdcd3b03f
Author: Brian Templeton <address@hidden>
Date: Sat Aug 14 19:28:56 2010 -0400
use unbound fluids instead of `void' sentinel value
* module/language/elisp/compile-tree-il.scm (reference-with-check)
(compile-without-void-checks, want-void-check?): Remove.
(compile-function, compile-pair): Use `reference-variable' instead of
`reference-with-check'.
(compile-defvar): Only set `sym' if `sym' is not bound to a bound
fluid, rather than requiring that its value be `void'.
(process-options!): Remove `#:disable-void-check' option handling.
* module/language/elisp/runtime.scm (void)
(reference-variable-with-check): Remove.
(ensure-fluid!): Use an undefined fluid as the initial value for
global variables.
* module/language/elisp/runtime/function-slot.scm (without-void-checks):
Don't import or re-export.
* module/language/elisp/runtime/macros.scm (prog1, cond, or, dolist):
Don't use `without-void-checks'.
* module/language/elisp/runtime/subrs.scm (symbol-value)
(symbol-function, apply): Use `reference-variable' instead of
`reference-variable-with-check'.
(makunbound, fmakunbound, boundp, fboundp): Unset the variable's fluid
(or the variable itself, if it isn't bound to a fluid).
* test-suite/tests/elisp-compiler.test ("Variable
Setting/Referencing")["disabled void check (all)", "disabled void
check (symbol list)", "without-void-checks"]: Remove.
Signed-off-by: Andy Wingo <address@hidden>
commit 67cb2c27610295aa68445951c03a7550efc9453a
Author: Brian Templeton <address@hidden>
Date: Thu Jul 22 16:33:53 2010 -0400
function's argument can be a symbol
* module/language/elisp/compile-tree-il.scm (compile-function): the form
`(function SYMBOL)' evaluates to the functional value of SYMBOL
Signed-off-by: Andy Wingo <address@hidden>
commit b41a673d2647eef7ff43469ed864bd584fcd9be2
Author: Brian Templeton <address@hidden>
Date: Thu Jul 22 16:25:29 2010 -0400
allow `(setcar nil nil)' and `(setcdr nil nil)'
* module/language/elisp/runtime/subrs.scm (setcar, setcdr): Allow
setting the car or cdr of `nil' to `nil'.
Signed-off-by: Andy Wingo <address@hidden>
commit b7966c10efaaaf95e3a6fe300e79d9c3c195bde5
Author: Brian Templeton <address@hidden>
Date: Thu Jul 22 15:12:50 2010 -0400
support "#'" syntax for function expressions
* module/language/elisp/lexer.scm (lex):
* module/language/elisp/parser.scm (get-expression): Support sharpsign
single-quote syntax as an abbreviation for `function' expressions.
Signed-off-by: Andy Wingo <address@hidden>
commit f5742cf042fbcdb9b8319a6b96fd32b03dcb42ca
Author: Brian Templeton <address@hidden>
Date: Sat Jul 10 02:47:16 2010 -0400
setq can take any number of arguments
* module/language/elisp/compile-tree-il.scm (compile-setq): Return nil
if called with no arguments, and set the last variable to nil if its
value is omitted.
Signed-off-by: Andy Wingo <address@hidden>
commit 0dbfdeefc6de02224892d6775aa0b64ade0f0a12
Author: Brian Templeton <address@hidden>
Date: Fri Jul 9 20:33:32 2010 -0400
use correct names for quasiquotation operators
Use #{`}#, #{,}# and #{,@}# as the quasiquote, unquote and
unquote-splicing operators, respectively. Previously they were named
escaping.
* module/language/elisp/compile-tree-il.scm (unquote?): Change "\," to
"#{,}#".
(unquote-splicing): Change "\,@" to "#{,@}#".
(#{compile-`}#): Rename from #{compile-\`}#.
* module/language/elisp/runtime/function-slot.scm: Import #{compile-`}#
instead of #{compile-\`}#, and re-export as #{`}# instead of as
#{\`}#.
* module/language/elisp/parser.scm (quotation-symbols):
* test-suite/tests/elisp-compiler.test ("Eval", "Quotation"):
* test-suite/tests/elisp-reader.test ("Parser"): Change "\`", "\,", and
"\,@" to "#{`}#", "#{,}#" and "#{,@}#", respectively.
commit 44ae163d2c469c62352cbce7dbb3542b421a2f8d
Author: Brian Templeton <address@hidden>
Date: Fri Jul 9 19:52:48 2010 -0400
store special operators in the function slot
If the function slot of a symbol contains a pair with `special-operator'
in the car and a procedure in the cdr, the procedure is called to
compile the form to Tree-IL. This is similar to other Emacs Lisp
implementations, in which special operators are subrs.
* module/language/elisp/compile-tree-il.scm: Restructured to store
special operator definitions in the function slot. Import `(language
elisp runtime)' for `defspecial'. Export special operators so that
`(language elisp runtime function-slot)' can re-export them.
(backquote?): Removed; the backquote symbol is defined as a special
operator, so it's no longer used in `compile-pair'.
(is-macro?, get-macro): Replaced by `find-operator'.
(find-operator): New procedure.
(compile-progn, compile-if, compile-defconst, compile-defvar,
compile-setq, compile-let, compile-lexical-let, compile-flet,
compile-let*, compile-lexical-let*, compile-flet*,
compile-without-void-checks, compile-with-always-lexical,
compile-guile-ref, compile-guile-primitive, compile-while,
compile-function, compile-defmacro, compile-defun, #{compile-`}#,
compile-quote): New special operators with definitions taken from the
pmatch form in `compile-pair'. There is no special operator `lambda';
it is now a macro, as in other Elisp implementations.
(compile-pair): Instead of directly compiling special forms, check for
a special operator object in the function slot.
* module/language/elisp/runtime.scm: Export `defspecial'.
(make-id): New function.
(built-in-macro): Prefix macros with `macro-'.
(defspecial): New syntax.
* module/language/elisp/runtime/function-slot.scm: Import and re-export
special operators. Rename imported special operators and macros to
remove prefixes. Re-export new macro `lambda'.
* module/language/elisp/runtime/macros.scm (macro-lambda): New Elisp
macro.
commit e9de35293f237081365879e1e637267b5eb058b6
Author: Brian Templeton <address@hidden>
Date: Thu Jul 1 22:38:23 2010 -0400
update elisp reader tests to handle EOF tokens
* test-suite/tests/elisp-reader.test (lex-all, "end-of-input",
"lexer/1"): Check for an EOF token instead of the symbol `*eoi*'.
commit 2ce5e74073519c7056c10239dc42de435f2e5bf8
Author: Brian Templeton <address@hidden>
Date: Wed Jun 30 16:54:45 2010 -0400
make user-defined macros available at runtime
* module/language/elisp/compile-tree-il.scm (ensuring-globals): New
procedure.
(define-macro!): Remove.
(compile-pair) <defmacro>: Make macro available at runtime, not only
during compilation.
(compile-tree-il): Use `ensuring-globals'.
commit 65b46b72417c375a212bb5e2bf8b833870c0269d
Author: Brian Templeton <address@hidden>
Date: Wed Jun 30 16:48:19 2010 -0400
allow fluid macro bindings
* module/language/elisp/compile-tree-il.scm (define-macro!, get-macro):
Allow fluid macro bindings.
commit 9efe5b230db733c491aabf3c5c424ee01a6a420c
Author: Brian Templeton <address@hidden>
Date: Tue Jun 29 21:18:05 2010 -0400
new `load' subr
* module/language/elisp/runtime/subrs.scm: Define new subr `load'.
* module/language/elisp/runtime/function-slot.scm: Re-export `load'.
commit 382991966332a67caf30b6ec00f39d74b2e4ae02
Author: Brian Templeton <address@hidden>
Date: Tue Jun 29 21:13:18 2010 -0400
Ignore #:warnings compiler option
* module/language/elisp/compile-tree-il.scm (process-options!): Ignore
#:warnings compiler option.
commit 1dfe593954b094bfd25738f1553baa3a557476a9
Author: Brian Templeton <address@hidden>
Date: Thu Jun 24 23:03:08 2010 -0400
handle EOF correctly in parser and lexer
* module/language/elisp/lexer.scm (lex, get-lexer/1): Return a valid
token at EOF.
* module/language/elisp/parser.scm (get-expression): Raise an error if
EOF is reached.
(read-elisp): If at EOF, return the EOF object instead of attempting
to read an expression.
Signed-off-by: Andy Wingo <address@hidden>
commit 8295b7c4e5637d363649101fa5080f9d31b80c14
Author: Brian Templeton <address@hidden>
Date: Wed Jun 23 19:31:33 2010 -0400
store macro definitions in the function slot
Guile Emacs Lisp previously kept macros in a separate macro slot; now
macros are stored as macro objects in the function slot for
compatibility with other implementations.
* module/language/elisp/compile-tree-il.scm (macro-slot): Remove.
(is-macro?): Check that the argument is a symbol. Now-unnecessary
check removed in `compile-tree-il'.
(macro?, define-macro!, get-macro): Store macro definitions in the
function slot, not in a separate macro slot.
* module/language/elisp/runtime.scm (built-in-macro): Wrap the macro
function in a macro object (i.e., cons the symbol `macro' onto it).
* module/language/elisp/runtime/function-slot.scm: Move contents to
"subrs.scm". Re-export function and macro definitions instead of
defining functions directly in this module.
* module/language/elisp/runtime/macro-slot.scm: Move contents to
"macros.scm" and remove.
* module/language/elisp/runtime/macros.scm: New file containing macro
definitions from "macro-slot.scm".
* module/language/elisp/runtime/subrs.scm: New file containing function
definitions from "function-slot.scm".
Signed-off-by: Andy Wingo <address@hidden>
commit 6e9ebc9179af52e90402ddd0b7f10f3857a0d329
Author: Brian Templeton <address@hidden>
Date: Thu Jun 17 20:25:42 2010 -0400
use existing bindings record for defmacro
* module/language/elisp/compile-tree-il.scm (compile-pair): Use existing
bindings record during macro definition.
commit eda83f0ac98ba3ba5655aa251ce8c5b4def70b34
Author: Brian Templeton <address@hidden>
Date: Wed Jun 16 17:18:30 2010 -0400
use tree-il's support for optional arguments
* module/language/elisp/compile-tree-il.scm (compile-lambda): Use
Tree-IL's support for optional arguments.
(process-optionals, process-rest): Remove.
Signed-off-by: Andy Wingo <address@hidden>
commit 450cb50419e6c203cb5b550d7bab925532921730
Author: Brian Templeton <address@hidden>
Date: Wed Jun 23 19:40:03 2010 -0400
make `pass-if-equal' literal in `compile-test'
* test-suite/tests/elisp-compiler.test (compile-test): Add
`pass-if-equal' to the list of literal identifiers
Signed-off-by: Andy Wingo <address@hidden>
commit f4e5e4114dad35276355470aa4096af3ec0b7d1c
Author: Brian Templeton <address@hidden>
Date: Mon Jun 7 16:38:23 2010 -0400
reindent
* module/language/elisp/bindings.scm:
* module/language/elisp/compile-tree-il.scm:
* module/language/elisp/lexer.scm:
* module/language/elisp/parser.scm:
* module/language/elisp/runtime.scm:
* module/language/elisp/runtime/function-slot.scm:
* module/language/elisp/runtime/macro-slot.scm:
* module/language/elisp/spec.scm: Reindent.
Signed-off-by: Andy Wingo <address@hidden>
commit c983a199d8a941d7183e10b7a1d1ecb2e3ede837
Author: Brian Templeton <address@hidden>
Date: Mon Jun 7 16:38:00 2010 -0400
reformat comments
* module/language/elisp/bindings.scm:
* module/language/elisp/compile-tree-il.scm:
* module/language/elisp/lexer.scm:
* module/language/elisp/parser.scm:
* module/language/elisp/runtime.scm:
* module/language/elisp/runtime/function-slot.scm:
* module/language/elisp/runtime/macro-slot.scm:
* module/language/elisp/runtime/value-slot.scm: Reformat comments.
Signed-off-by: Andy Wingo <address@hidden>
commit abcf4a9e1dc06607ddb43861e33a982e36ffac4b
Author: Brian Templeton <address@hidden>
Date: Mon Jun 7 16:37:24 2010 -0400
whitespace changes
* module/language/elisp/bindings.scm:
* module/language/elisp/compile-tree-il.scm:
* module/language/elisp/lexer.scm:
* module/language/elisp/parser.scm:
* module/language/elisp/runtime.scm:
* module/language/elisp/runtime/function-slot.scm:
* module/language/elisp/runtime/macro-slot.scm: Ensure that all
top-level forms and comments are separated by exactly one newline.
Remove blank lines in most procedure bodies. Delete trailing
whitespace.
Signed-off-by: Andy Wingo <address@hidden>
commit 9c933e1d3f72d9d8693e030c24de44adc9f9e0b9
Author: Brian Templeton <address@hidden>
Date: Wed Jul 14 17:47:37 2010 -0400
autoload compile-file in (guile-user)
* module/ice-9/boot-9.scm (guile-user): Autoload `compile-file'.
commit a8aa4c0b56624dc77b71d6b4892f6b14ad9e751d
Author: Brian Templeton <address@hidden>
Date: Sat Aug 14 19:00:20 2010 -0400
variable-unset!
* libguile/variable.c (scm_variable_unset_x): New function.
* libguile/variable.h (scm_variable_unset_x): New prototype.
commit ef94624eaf549ca9c730d4650b9dfed2ee48521b
Author: Brian Templeton <address@hidden>
Date: Sat Aug 14 18:35:17 2010 -0400
unbound fluids
* libguile/fluids.c (scm_make_undefined_fluid, scm_fluid_unset_x)
(scm_fluid_bound_p): New functions.
(fluid_ref): New function; like scm_fluid_ref, but will not throw an
error for unbound fluids.
(scm_fluid_ref, swap_fluid): Use `fluid_ref'.
* libguile/fluids.h (scm_make_undefined_fluid, scm_fluid_unset_x)
(scm_fluid_bound_p): New prototypes.
* libguile/vm-i-system.c (fluid_ref): If fluid is unbound, jump to
`vm_error_unbound_fluid'.
* libguile/vm-engine.c (VM_NAME)[vm_error_unbound_fluid]: New error
message.
* test-suite/tests/fluids.test ("unbound fluids")["fluid-ref of unbound
fluid", "fluid-bound? of bound fluid", "fluid-bound? of unbound
fluid", "unbound fluids can be set", "bound fluids can be unset"]: New
tests.
commit d1079217947013dac495a95e433ad5da9f7aa80a
Author: Andy Wingo <address@hidden>
Date: Tue Dec 7 12:26:07 2010 +0100
better unbound variable errors in the vm
* libguile/vm-i-system.c (variable-ref, toplevel-ref)
(long-toplevel-ref): Fixup callers.
* libguile/vm-engine.c (vm_error_unbound): Don't use vm-error for
unbound vars, use misc-error. Don't include VM: in the string. Take
the name directly in finish_args, not as a list.
commit 1f845305c184814e253f0c4ac5a2aaac874b20a2
Author: Brian Templeton <address@hidden>
Date: Tue Jul 13 20:55:45 2010 -0400
make guile-test work without configuration
* test-suite/guile-test: Use "../meta/guile" as the interpreter instead
of "../libguile/guile".
(default-test-suite): New function, replacing the variable of the same
name. Look for tests in the same directory as the guile-test script.
Throw an error if not invoked as `guile-test'.
(test-suite): The old default value of `default-test-suite' could now
throw an error, and this already gets initialized in `main', so don't
provide an initial value.
-----------------------------------------------------------------------
Summary of changes:
libguile/fluids.c | 64 +-
libguile/fluids.h | 3 +
libguile/variable.c | 12 +
libguile/variable.h | 1 +
libguile/vm-engine.c | 15 +-
libguile/vm-i-system.c | 16 +-
module/Makefile.am | 3 +-
module/ice-9/boot-9.scm | 2 +-
module/language/elisp/bindings.scm | 128 +-
module/language/elisp/compile-tree-il.scm | 1456 ++++++++++++-----------
module/language/elisp/lexer.scm | 583 +++++-----
module/language/elisp/parser.scm | 243 ++--
module/language/elisp/runtime.scm | 151 ++-
module/language/elisp/runtime/function-slot.scm | 435 +++-----
module/language/elisp/runtime/macro-slot.scm | 209 ----
module/language/elisp/runtime/macros.scm | 208 ++++
module/language/elisp/runtime/subrs.scm | 383 ++++++
module/language/elisp/runtime/value-slot.scm | 4 +-
module/language/elisp/spec.scm | 12 +-
test-suite/guile-test | 13 +-
test-suite/tests/elisp-compiler.test | 38 +-
test-suite/tests/elisp-reader.test | 14 +-
test-suite/tests/fluids.test | 20 +
23 files changed, 2215 insertions(+), 1798 deletions(-)
delete mode 100644 module/language/elisp/runtime/macro-slot.scm
create mode 100644 module/language/elisp/runtime/macros.scm
create mode 100644 module/language/elisp/runtime/subrs.scm
diff --git a/libguile/fluids.c b/libguile/fluids.c
index 8b31c85..6d048a0 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -181,6 +181,17 @@ SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_make_undefined_fluid, "make-undefined-fluid", 0, 0, 0,
+ (),
+ "")
+#define FUNC_NAME s_scm_make_undefined_fluid
+{
+ SCM f = new_fluid ();
+ scm_fluid_set_x (f, SCM_UNDEFINED);
+ return f;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0,
(SCM obj),
"Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
@@ -197,19 +208,12 @@ scm_is_fluid (SCM obj)
return IS_FLUID (obj);
}
-
-
-SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
- (SCM fluid),
- "Return the value associated with @var{fluid} in the current\n"
- "dynamic root. If @var{fluid} has not been set, then return\n"
- "@code{#f}.")
-#define FUNC_NAME s_scm_fluid_ref
+/* Does not check type of `fluid'! */
+static SCM
+fluid_ref (SCM fluid)
{
SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
- SCM_VALIDATE_FLUID (1, fluid);
-
if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
{
/* Lazily grow the current thread's dynamic state. */
@@ -220,6 +224,22 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
return SCM_SIMPLE_VECTOR_REF (fluids, FLUID_NUM (fluid));
}
+
+SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
+ (SCM fluid),
+ "Return the value associated with @var{fluid} in the current\n"
+ "dynamic root. If @var{fluid} has not been set, then return\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_fluid_ref
+{
+ SCM val;
+ SCM_VALIDATE_FLUID (1, fluid);
+ val = fluid_ref (fluid);
+ if (SCM_UNBNDP (val))
+ SCM_MISC_ERROR ("unbound fluid: ~S",
+ scm_list_1 (fluid));
+ return val;
+}
#undef FUNC_NAME
SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
@@ -244,6 +264,28 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_fluid_unset_x, "fluid-unset!", 1, 0, 0,
+ (SCM fluid),
+ "Unset the value associated with @var{fluid}.")
+#define FUNC_NAME s_scm_fluid_unset_x
+{
+ return scm_fluid_set_x (fluid, SCM_UNDEFINED);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_fluid_bound_p, "fluid-bound?", 1, 0, 0,
+ (SCM fluid),
+ "Return @code{#t} iff @var{fluid} is bound to a value.\n"
+ "Throw an error if @var{fluid} is not a fluid.")
+#define FUNC_NAME s_scm_fluid_bound_p
+{
+ SCM val;
+ SCM_VALIDATE_FLUID (1, fluid);
+ val = fluid_ref (fluid);
+ return scm_from_bool (! (SCM_UNBNDP (val)));
+}
+#undef FUNC_NAME
+
static SCM
apply_thunk (void *thunk)
{
@@ -406,7 +448,7 @@ static void
swap_fluid (SCM data)
{
SCM f = SCM_CAR (data);
- SCM t = scm_fluid_ref (f);
+ SCM t = fluid_ref (f);
scm_fluid_set_x (f, SCM_CDR (data));
SCM_SETCDR (data, t);
}
diff --git a/libguile/fluids.h b/libguile/fluids.h
index d837414..db82203 100644
--- a/libguile/fluids.h
+++ b/libguile/fluids.h
@@ -60,10 +60,13 @@
#endif
SCM_API SCM scm_make_fluid (void);
+SCM_API SCM scm_make_undefined_fluid (void);
SCM_API int scm_is_fluid (SCM obj);
SCM_API SCM scm_fluid_p (SCM fl);
SCM_API SCM scm_fluid_ref (SCM fluid);
SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value);
+SCM_API SCM scm_fluid_unset_x (SCM fluid);
+SCM_API SCM scm_fluid_bound_p (SCM fluid);
SCM_INTERNAL SCM scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals);
SCM_INTERNAL void scm_i_swap_with_fluids (SCM with_fluids, SCM dynamic_state);
diff --git a/libguile/variable.c b/libguile/variable.c
index a97444c..76fbf18 100644
--- a/libguile/variable.c
+++ b/libguile/variable.c
@@ -111,6 +111,18 @@ SCM_DEFINE (scm_variable_set_x, "variable-set!", 2, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_variable_unset_x, "variable-unset!", 1, 0, 0,
+ (SCM var),
+ "Ensure that @var{var} is not bound to a value.\n"
+ "@var{var} must be a variable object.")
+#define FUNC_NAME s_scm_variable_unset_x
+{
+ SCM_VALIDATE_VARIABLE (1, var);
+ SCM_VARIABLE_SET (var, SCM_UNDEFINED);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_variable_bound_p, "variable-bound?", 1, 0, 0,
(SCM var),
"Return @code{#t} iff @var{var} is bound to a value.\n"
diff --git a/libguile/variable.h b/libguile/variable.h
index 8faced4..20daf85 100644
--- a/libguile/variable.h
+++ b/libguile/variable.h
@@ -42,6 +42,7 @@ SCM_API SCM scm_make_undefined_variable (void);
SCM_API SCM scm_variable_p (SCM obj);
SCM_API SCM scm_variable_ref (SCM var);
SCM_API SCM scm_variable_set_x (SCM var, SCM val);
+SCM_API SCM scm_variable_unset_x (SCM var);
SCM_API SCM scm_variable_bound_p (SCM var);
SCM_INTERNAL void scm_i_variable_print (SCM var, SCM port, scm_print_state
*pstate);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 5b38060..e69167f 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -139,9 +139,18 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
goto vm_error;
vm_error_unbound:
- /* At this point FINISH_ARGS should be a one-element list containing
- the name of the unbound variable. */
- err_msg = scm_from_locale_string ("VM: Unbound variable: ~s");
+ /* FINISH_ARGS should be the name of the unbound variable. */
+ SYNC_ALL ();
+ err_msg = scm_from_locale_string ("Unbound variable: ~s");
+ scm_error_scm (scm_misc_error_key, program, err_msg,
+ scm_list_1 (finish_args), SCM_BOOL_F);
+ goto vm_error;
+
+ vm_error_unbound_fluid:
+ SYNC_ALL ();
+ err_msg = scm_from_locale_string ("Unbound fluid: ~s");
+ scm_error_scm (scm_misc_error_key, program, err_msg,
+ scm_list_1 (finish_args), SCM_BOOL_F);
goto vm_error;
vm_error_apply_to_non_list:
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index bc0c962..5b40c1b 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -306,7 +306,7 @@ VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 0,
1, 1)
/* Attempt to provide the variable name in the error message. */
var_name = scm_module_reverse_lookup (scm_current_module (), x);
- finish_args = scm_list_1 (scm_is_true (var_name) ? var_name : x);
+ finish_args = scm_is_true (var_name) ? var_name : x;
goto vm_error_unbound;
}
else
@@ -340,7 +340,7 @@ VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1,
0, 1)
resolved = resolve_variable (what, scm_program_module (program));
if (!VARIABLE_BOUNDP (resolved))
{
- finish_args = scm_list_1 (what);
+ finish_args = what;
goto vm_error_unbound;
}
what = resolved;
@@ -366,7 +366,7 @@ VM_DEFINE_INSTRUCTION (28, long_toplevel_ref,
"long-toplevel-ref", 2, 0, 1)
resolved = resolve_variable (what, scm_program_module (program));
if (!VARIABLE_BOUNDP (resolved))
{
- finish_args = scm_list_1 (what);
+ finish_args = what;
goto vm_error_unbound;
}
what = resolved;
@@ -1612,7 +1612,15 @@ VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1,
1)
*sp = scm_fluid_ref (*sp);
}
else
- *sp = SCM_SIMPLE_VECTOR_REF (fluids, num);
+ {
+ SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
+ if (SCM_UNLIKELY (val == SCM_UNDEFINED))
+ {
+ finish_args = *sp;
+ goto vm_error_unbound_fluid;
+ }
+ *sp = val;
+ }
NEXT;
}
diff --git a/module/Makefile.am b/module/Makefile.am
index 67d530a..f9fc367 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -135,8 +135,9 @@ ELISP_LANG_SOURCES = \
language/elisp/compile-tree-il.scm \
language/elisp/runtime.scm \
language/elisp/runtime/function-slot.scm \
- language/elisp/runtime/macro-slot.scm \
language/elisp/runtime/value-slot.scm \
+ language/elisp/runtime/macros.scm \
+ language/elisp/runtime/subrs.scm \
language/elisp/spec.scm
BRAINFUCK_LANG_SOURCES = \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 6da81a7..1a61ce0 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3322,7 +3322,7 @@ module '(ice-9 q) '(make-q q-length))}."
(module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
(define-module (guile-user)
- #:autoload (system base compile) (compile))
+ #:autoload (system base compile) (compile compile-file))
;; Remain in the `(guile)' module at compilation-time so that the
;; `-Wunused-toplevel' warning works as expected.
diff --git a/module/language/elisp/bindings.scm
b/module/language/elisp/bindings.scm
index 074b95a..6ff56fd 100644
--- a/module/language/elisp/bindings.scm
+++ b/module/language/elisp/bindings.scm
@@ -1,6 +1,6 @@
;;; Guile Emacs Lisp
-;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -20,108 +20,110 @@
(define-module (language elisp bindings)
#:export (make-bindings
- mark-global-needed! map-globals-needed
- with-lexical-bindings with-dynamic-bindings
+ mark-global-needed!
+ map-globals-needed
+ with-lexical-bindings
+ with-dynamic-bindings
get-lexical-binding))
-; This module defines routines to handle analysis of symbol bindings used
-; during elisp compilation. This data allows to collect the symbols, for
-; which globals need to be created, or mark certain symbols as lexically bound.
-
-; Needed globals are stored in an association-list that stores a list of
symbols
-; for each module they are needed in.
-
-; The lexical bindings of symbols are stored in a hash-table that associates
-; symbols to fluids; those fluids are used in the with-lexical-binding and
-; with-dynamic-binding routines to associate symbols to different bindings
-; over a dynamic extent.
-
+;;; This module defines routines to handle analysis of symbol bindings
+;;; used during elisp compilation. This data allows to collect the
+;;; symbols, for which globals need to be created, or mark certain
+;;; symbols as lexically bound.
+;;;
+;;; Needed globals are stored in an association-list that stores a list
+;;; of symbols for each module they are needed in.
+;;;
+;;; The lexical bindings of symbols are stored in a hash-table that
+;;; associates symbols to fluids; those fluids are used in the
+;;; with-lexical-binding and with-dynamic-binding routines to associate
+;;; symbols to different bindings over a dynamic extent.
-; Record type used to hold the data necessary.
+;;; Record type used to hold the data necessary.
(define bindings-type
- (make-record-type 'bindings
- '(needed-globals lexical-bindings)))
+ (make-record-type 'bindings '(needed-globals lexical-bindings)))
-
-; Construct an 'empty' instance of the bindings data structure to be used
-; at the start of a fresh compilation.
+;;; Construct an 'empty' instance of the bindings data structure to be
+;;; used at the start of a fresh compilation.
(define (make-bindings)
((record-constructor bindings-type) '() (make-hash-table)))
-
-; Mark that a given symbol is needed as global in the specified slot-module.
+;;; Mark that a given symbol is needed as global in the specified
+;;; slot-module.
(define (mark-global-needed! bindings sym module)
- (let* ((old-needed ((record-accessor bindings-type 'needed-globals)
bindings))
+ (let* ((old-needed ((record-accessor bindings-type 'needed-globals)
+ bindings))
(old-in-module (or (assoc-ref old-needed module) '()))
(new-in-module (if (memq sym old-in-module)
- old-in-module
- (cons sym old-in-module)))
+ old-in-module
+ (cons sym old-in-module)))
(new-needed (assoc-set! old-needed module new-in-module)))
- ((record-modifier bindings-type 'needed-globals) bindings new-needed)))
+ ((record-modifier bindings-type 'needed-globals)
+ bindings
+ new-needed)))
-
-; Cycle through all globals needed in order to generate the code for their
-; creation or some other analysis.
+;;; Cycle through all globals needed in order to generate the code for
+;;; their creation or some other analysis.
(define (map-globals-needed bindings proc)
- (let ((needed ((record-accessor bindings-type 'needed-globals) bindings)))
+ (let ((needed ((record-accessor bindings-type 'needed-globals)
+ bindings)))
(let iterate-modules ((mod-tail needed)
(mod-result '()))
(if (null? mod-tail)
- mod-result
- (iterate-modules
- (cdr mod-tail)
- (let* ((aentry (car mod-tail))
- (module (car aentry))
- (symbols (cdr aentry)))
- (let iterate-symbols ((sym-tail symbols)
- (sym-result mod-result))
- (if (null? sym-tail)
- sym-result
- (iterate-symbols (cdr sym-tail)
- (cons (proc module (car sym-tail))
- sym-result))))))))))
-
-
-; Get the current lexical binding (gensym it should refer to in the current
-; scope) for a symbol or #f if it is dynamically bound.
+ mod-result
+ (iterate-modules
+ (cdr mod-tail)
+ (let* ((aentry (car mod-tail))
+ (module (car aentry))
+ (symbols (cdr aentry)))
+ (let iterate-symbols ((sym-tail symbols)
+ (sym-result mod-result))
+ (if (null? sym-tail)
+ sym-result
+ (iterate-symbols (cdr sym-tail)
+ (cons (proc module (car sym-tail))
+ sym-result))))))))))
+
+;;; Get the current lexical binding (gensym it should refer to in the
+;;; current scope) for a symbol or #f if it is dynamically bound.
(define (get-lexical-binding bindings sym)
- (let* ((lex ((record-accessor bindings-type 'lexical-bindings) bindings))
+ (let* ((lex ((record-accessor bindings-type 'lexical-bindings)
+ bindings))
(slot (hash-ref lex sym #f)))
(if slot
- (fluid-ref slot)
- #f)))
-
+ (fluid-ref slot)
+ #f)))
-; Establish a binding or mark a symbol as dynamically bound for the extent of
-; calling proc.
+;;; Establish a binding or mark a symbol as dynamically bound for the
+;;; extent of calling proc.
(define (with-symbol-bindings bindings syms targets proc)
(if (or (not (list? syms))
(not (and-map symbol? syms)))
- (error "can't bind non-symbols" syms))
- (let ((lex ((record-accessor bindings-type 'lexical-bindings) bindings)))
+ (error "can't bind non-symbols" syms))
+ (let ((lex ((record-accessor bindings-type 'lexical-bindings)
+ bindings)))
(for-each (lambda (sym)
(if (not (hash-ref lex sym))
- (hash-set! lex sym (make-fluid))))
+ (hash-set! lex sym (make-fluid))))
syms)
- (with-fluids* (map (lambda (sym)
- (hash-ref lex sym))
- syms)
+ (with-fluids* (map (lambda (sym) (hash-ref lex sym)) syms)
targets
proc)))
(define (with-lexical-bindings bindings syms targets proc)
(if (or (not (list? targets))
(not (and-map symbol? targets)))
- (error "invalid targets for lexical binding" targets)
- (with-symbol-bindings bindings syms targets proc)))
+ (error "invalid targets for lexical binding" targets)
+ (with-symbol-bindings bindings syms targets proc)))
(define (with-dynamic-bindings bindings syms proc)
(with-symbol-bindings bindings
- syms (map (lambda (el) #f) syms)
+ syms
+ (map (lambda (el) #f) syms)
proc))
diff --git a/module/language/elisp/compile-tree-il.scm
b/module/language/elisp/compile-tree-il.scm
index 1701f0f..0df21c7 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -6,12 +6,12 @@
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
-;;
+;;
;; This program 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
@@ -21,30 +21,57 @@
(define-module (language elisp compile-tree-il)
#:use-module (language elisp bindings)
+ #:use-module (language elisp runtime)
#:use-module (language tree-il)
#:use-module (system base pmatch)
#:use-module (system base compile)
#:use-module (srfi srfi-1)
- #:export (compile-tree-il))
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:export (compile-tree-il
+ compile-progn
+ compile-if
+ compile-defconst
+ compile-defvar
+ compile-setq
+ compile-let
+ compile-lexical-let
+ compile-flet
+ compile-let*
+ compile-lexical-let*
+ compile-flet*
+ compile-without-void-checks
+ compile-with-always-lexical
+ compile-guile-ref
+ compile-guile-primitive
+ compile-while
+ compile-function
+ compile-defmacro
+ compile-defun
+ #{compile-`}#
+ compile-quote))
+
+;;; Certain common parameters (like the bindings data structure or
+;;; compiler options) are not always passed around but accessed using
+;;; fluids to simulate dynamic binding (hey, this is about elisp).
+
+;;; The bindings data structure to keep track of symbol binding related
+;;; data.
-
-; Certain common parameters (like the bindings data structure or compiler
-; options) are not always passed around but accessed using fluids to simulate
-; dynamic binding (hey, this is about elisp).
-
-; The bindings data structure to keep track of symbol binding related data.
(define bindings-data (make-fluid))
-; Store for which symbols (or all/none) void checks are disabled.
+;;; Store for which symbols (or all/none) void checks are disabled.
+
(define disable-void-check (make-fluid))
-; Store which symbols (or all/none) should always be bound lexically, even
-; with ordinary let and as lambda arguments.
-(define always-lexical (make-fluid))
+;;; Store which symbols (or all/none) should always be bound lexically,
+;;; even with ordinary let and as lambda arguments.
+(define always-lexical (make-fluid))
-; Find the source properties of some parsed expression if there are any
-; associated with it.
+;;; Find the source properties of some parsed expression if there are
+;;; any associated with it.
(define (location x)
(and (pair? x)
@@ -52,169 +79,172 @@
(and (not (null? props))
props))))
+;;; Values to use for Elisp's nil and t.
-; Values to use for Elisp's nil and t.
+(define (nil-value loc)
+ (make-const loc (@ (language elisp runtime) nil-value)))
-(define (nil-value loc) (make-const loc (@ (language elisp runtime)
nil-value)))
-(define (t-value loc) (make-const loc (@ (language elisp runtime) t-value)))
+(define (t-value loc)
+ (make-const loc (@ (language elisp runtime) t-value)))
-
-; Modules that contain the value and function slot bindings.
+;;; Modules that contain the value and function slot bindings.
(define runtime '(language elisp runtime))
-(define macro-slot '(language elisp runtime macro-slot))
-(define value-slot (@ (language elisp runtime) value-slot-module))
-(define function-slot (@ (language elisp runtime) function-slot-module))
+(define value-slot (@ (language elisp runtime) value-slot-module))
-; The backquoting works the same as quasiquotes in Scheme, but the forms are
-; named differently; to make easy adaptions, we define these predicates
checking
-; for a symbol being the car of an unquote/unquote-splicing/backquote form.
+(define function-slot (@ (language elisp runtime) function-slot-module))
-(define (backquote? sym)
- (and (symbol? sym) (eq? sym '\`)))
+;;; The backquoting works the same as quasiquotes in Scheme, but the
+;;; forms are named differently; to make easy adaptions, we define these
+;;; predicates checking for a symbol being the car of an
+;;; unquote/unquote-splicing/backquote form.
(define (unquote? sym)
- (and (symbol? sym) (eq? sym '\,)))
+ (and (symbol? sym) (eq? sym '#{,}#)))
(define (unquote-splicing? sym)
- (and (symbol? sym) (eq? sym '\,@)))
-
+ (and (symbol? sym) (eq? sym '#{,@}#)))
-; Build a call to a primitive procedure nicely.
+;;; Build a call to a primitive procedure nicely.
(define (call-primitive loc sym . args)
(make-application loc (make-primitive-ref loc sym) args))
-
-; Error reporting routine for syntax/compilation problems or build code for
-; a runtime-error output.
+;;; Error reporting routine for syntax/compilation problems or build
+;;; code for a runtime-error output.
(define (report-error loc . args)
(apply error args))
(define (runtime-error loc msg . args)
- (make-application loc (make-primitive-ref loc 'error)
- (cons (make-const loc msg) args)))
+ (make-application loc
+ (make-primitive-ref loc 'error)
+ (cons (make-const loc msg) args)))
-
-; Generate code to ensure a global symbol is there for further use of a given
-; symbol. In general during the compilation, those needed are only tracked
with
-; the bindings data structure. Afterwards, however, for all those needed
-; symbols the globals are really generated with this routine.
+;;; Generate code to ensure a global symbol is there for further use of
+;;; a given symbol. In general during the compilation, those needed are
+;;; only tracked with the bindings data structure. Afterwards, however,
+;;; for all those needed symbols the globals are really generated with
+;;; this routine.
(define (generate-ensure-global loc sym module)
- (make-application loc (make-module-ref loc runtime 'ensure-fluid! #t)
- (list (make-const loc module)
- (make-const loc sym))))
-
-
-; See if we should do a void-check for a given variable. That means, check
-; that this check is not disabled via the compiler options for this symbol.
-; Disabling of void check is only done for the value-slot module!
-
-(define (want-void-check? sym module)
- (let ((disabled (fluid-ref disable-void-check)))
- (or (not (equal? module value-slot))
- (and (not (eq? disabled 'all))
- (not (memq sym disabled))))))
-
-
-; Build a construct that establishes dynamic bindings for certain variables.
-; We may want to choose between binding with fluids and with-fluids* and
-; using just ordinary module symbols and setting/reverting their values with
-; a dynamic-wind.
+ (make-application loc
+ (make-module-ref loc runtime 'ensure-fluid! #t)
+ (list (make-const loc module)
+ (make-const loc sym))))
+
+(define (ensuring-globals loc bindings body)
+ (make-sequence
+ loc
+ `(,@(map-globals-needed (fluid-ref bindings)
+ (lambda (mod sym)
+ (generate-ensure-global loc sym mod)))
+ ,body)))
+
+;;; Build a construct that establishes dynamic bindings for certain
+;;; variables. We may want to choose between binding with fluids and
+;;; with-fluids* and using just ordinary module symbols and
+;;; setting/reverting their values with a dynamic-wind.
(define (let-dynamic loc syms module vals body)
- (call-primitive loc 'with-fluids*
- (make-application loc (make-primitive-ref loc 'list)
- (map (lambda (sym)
- (make-module-ref loc module sym #t))
- syms))
- (make-application loc (make-primitive-ref loc 'list) vals)
- (make-lambda loc '()
- (make-lambda-case #f '() #f #f #f '() '() body #f))))
-
-
-; Handle access to a variable (reference/setting) correctly depending on
-; whether it is currently lexically or dynamically bound.
-; lexical access is done only for references to the value-slot module!
-
-(define (access-variable loc sym module handle-lexical handle-dynamic)
+ (call-primitive
+ loc
+ 'with-fluids*
+ (make-application loc
+ (make-primitive-ref loc 'list)
+ (map (lambda (sym)
+ (make-module-ref loc module sym #t))
+ syms))
+ (make-application loc (make-primitive-ref loc 'list) vals)
+ (make-lambda loc
+ '()
+ (make-lambda-case #f '() #f #f #f '() '() body #f))))
+
+;;; Handle access to a variable (reference/setting) correctly depending
+;;; on whether it is currently lexically or dynamically bound. lexical
+;;; access is done only for references to the value-slot module!
+
+(define (access-variable loc
+ sym
+ module
+ handle-global
+ handle-lexical
+ handle-dynamic)
(let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
- (if (and lexical (equal? module value-slot))
- (handle-lexical lexical)
- (handle-dynamic))))
-
+ (cond
+ (lexical (handle-lexical lexical))
+ ((equal? module function-slot) (handle-global))
+ (else (handle-dynamic)))))
-; Generate code to reference a variable.
-; For references in the value-slot module, we may want to generate a lexical
-; reference instead if the variable has a lexical binding.
+;;; Generate code to reference a variable. For references in the
+;;; value-slot module, we may want to generate a lexical reference
+;;; instead if the variable has a lexical binding.
(define (reference-variable loc sym module)
- (access-variable loc sym module
- (lambda (lexical)
- (make-lexical-ref loc lexical lexical))
- (lambda ()
- (mark-global-needed! (fluid-ref bindings-data) sym module)
- (call-primitive loc 'fluid-ref
- (make-module-ref loc module sym #t)))))
-
-
-; Reference a variable and error if the value is void.
-
-(define (reference-with-check loc sym module)
- (if (want-void-check? sym module)
- (let ((var (gensym)))
- (make-let loc '(value) `(,var) `(,(reference-variable loc sym module))
- (make-conditional loc
- (call-primitive loc 'eq?
- (make-module-ref loc runtime 'void #t)
- (make-lexical-ref loc 'value var))
- (runtime-error loc "variable is void:" (make-const loc sym))
- (make-lexical-ref loc 'value var))))
- (reference-variable loc sym module)))
-
-
-; Generate code to set a variable.
-; Just as with reference-variable, in case of a reference to value-slot,
-; we want to generate a lexical set when the variable has a lexical binding.
+ (access-variable
+ loc
+ sym
+ module
+ (lambda () (make-module-ref loc module sym #t))
+ (lambda (lexical) (make-lexical-ref loc lexical lexical))
+ (lambda ()
+ (mark-global-needed! (fluid-ref bindings-data) sym module)
+ (call-primitive loc
+ 'fluid-ref
+ (make-module-ref loc module sym #t)))))
+
+;;; Generate code to set a variable. Just as with reference-variable, in
+;;; case of a reference to value-slot, we want to generate a lexical set
+;;; when the variable has a lexical binding.
(define (set-variable! loc sym module value)
- (access-variable loc sym module
- (lambda (lexical)
- (make-lexical-set loc lexical lexical value))
- (lambda ()
- (mark-global-needed! (fluid-ref bindings-data) sym module)
- (call-primitive loc 'fluid-set!
- (make-module-ref loc module sym #t)
- value))))
-
-
-; Process the bindings part of a let or let* expression; that is, check for
-; correctness and bring it to the form ((sym1 . val1) (sym2 . val2) ...).
+ (access-variable
+ loc
+ sym
+ module
+ (lambda ()
+ (make-application
+ loc
+ (make-module-ref loc runtime 'set-variable! #t)
+ (list (make-const loc module) (make-const loc sym) value)))
+ (lambda (lexical) (make-lexical-set loc lexical lexical value))
+ (lambda ()
+ (mark-global-needed! (fluid-ref bindings-data) sym module)
+ (call-primitive loc
+ 'fluid-set!
+ (make-module-ref loc module sym #t)
+ value))))
+
+;;; Process the bindings part of a let or let* expression; that is,
+;;; check for correctness and bring it to the form ((sym1 . val1) (sym2
+;;; . val2) ...).
(define (process-let-bindings loc bindings)
- (map (lambda (b)
- (if (symbol? b)
- (cons b 'nil)
- (if (or (not (list? b))
- (not (= (length b) 2)))
- (report-error loc "expected symbol or list of 2 elements in let")
+ (map
+ (lambda (b)
+ (if (symbol? b)
+ (cons b 'nil)
+ (if (or (not (list? b))
+ (not (= (length b) 2)))
+ (report-error
+ loc
+ "expected symbol or list of 2 elements in let")
(if (not (symbol? (car b)))
- (report-error loc "expected symbol in let")
- (cons (car b) (cadr b))))))
- bindings))
+ (report-error loc "expected symbol in let")
+ (cons (car b) (cadr b))))))
+ bindings))
-
-; Split the let bindings into a list to be done lexically and one dynamically.
-; A symbol will be bound lexically if and only if:
-; We're processing a lexical-let (i.e. module is 'lexical), OR
-; we're processing a value-slot binding AND
-; the symbol is already lexically bound or it is always lexical.
+;;; Split the let bindings into a list to be done lexically and one
+;;; dynamically. A symbol will be bound lexically if and only if: We're
+;;; processing a lexical-let (i.e. module is 'lexical), OR we're
+;;; processing a value-slot binding AND the symbol is already lexically
+;;; bound or is always lexical, OR we're processing a function-slot
+;;; binding.
(define (bind-lexically? sym module)
(or (eq? module 'lexical)
+ (eq? module function-slot)
(and (equal? module value-slot)
(let ((always (fluid-ref always-lexical)))
(or (eq? always 'all)
@@ -226,91 +256,108 @@
(lexical '())
(dynamic '()))
(if (null? tail)
- (values (reverse lexical) (reverse dynamic))
- (if (bind-lexically? (caar tail) module)
- (iterate (cdr tail) (cons (car tail) lexical) dynamic)
- (iterate (cdr tail) lexical (cons (car tail) dynamic))))))
-
-
-; Compile let and let* expressions. The code here is used both for let/let*
-; and flet/flet*, just with a different bindings module.
-;
-; A special module value 'lexical means that we're doing a lexical-let instead
-; and the bindings should not be saved to globals at all but be done with the
-; lexical framework instead.
-
-; Let is done with a single call to let-dynamic binding them locally to new
-; values all "at once". If there is at least one variable to bind lexically
-; among the bindings, we first do a let for all of them to evaluate all
-; values before any bindings take place, and then call let-dynamic for the
-; variables to bind dynamically.
+ (values (reverse lexical) (reverse dynamic))
+ (if (bind-lexically? (caar tail) module)
+ (iterate (cdr tail) (cons (car tail) lexical) dynamic)
+ (iterate (cdr tail) lexical (cons (car tail) dynamic))))))
+
+;;; Compile let and let* expressions. The code here is used both for
+;;; let/let* and flet/flet*, just with a different bindings module.
+;;;
+;;; A special module value 'lexical means that we're doing a lexical-let
+;;; instead and the bindings should not be saved to globals at all but
+;;; be done with the lexical framework instead.
+
+;;; Let is done with a single call to let-dynamic binding them locally
+;;; to new values all "at once". If there is at least one variable to
+;;; bind lexically among the bindings, we first do a let for all of them
+;;; to evaluate all values before any bindings take place, and then call
+;;; let-dynamic for the variables to bind dynamically.
+
(define (generate-let loc module bindings body)
(let ((bind (process-let-bindings loc bindings)))
(call-with-values
- (lambda ()
- (split-let-bindings bind module))
+ (lambda () (split-let-bindings bind module))
(lambda (lexical dynamic)
(for-each (lambda (sym)
- (mark-global-needed! (fluid-ref bindings-data) sym module))
+ (mark-global-needed! (fluid-ref bindings-data)
+ sym
+ module))
(map car dynamic))
(let ((make-values (lambda (for)
- (map (lambda (el)
- (compile-expr (cdr el)))
+ (map (lambda (el) (compile-expr (cdr el)))
for)))
(make-body (lambda ()
(make-sequence loc (map compile-expr body)))))
(if (null? lexical)
- (let-dynamic loc (map car dynamic) module
- (make-values dynamic) (make-body))
- (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
- (dynamic-syms (map (lambda (el) (gensym)) dynamic))
- (all-syms (append lexical-syms dynamic-syms))
- (vals (append (make-values lexical) (make-values dynamic))))
- (make-let loc all-syms all-syms vals
- (with-lexical-bindings (fluid-ref bindings-data)
- (map car lexical) lexical-syms
- (lambda ()
- (if (null? dynamic)
- (make-body)
- (let-dynamic loc (map car dynamic) module
- (map (lambda (sym)
- (make-lexical-ref loc sym sym))
- dynamic-syms)
- (make-body)))))))))))))
-
-
-; Let* is compiled to a cascaded set of "small lets" for each binding in turn
-; so that each one already sees the preceding bindings.
+ (let-dynamic loc (map car dynamic) module
+ (make-values dynamic) (make-body))
+ (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
+ (dynamic-syms (map (lambda (el) (gensym)) dynamic))
+ (all-syms (append lexical-syms dynamic-syms))
+ (vals (append (make-values lexical)
+ (make-values dynamic))))
+ (make-let loc
+ all-syms
+ all-syms
+ vals
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ (map car lexical) lexical-syms
+ (lambda ()
+ (if (null? dynamic)
+ (make-body)
+ (let-dynamic loc
+ (map car dynamic)
+ module
+ (map
+ (lambda (sym)
+ (make-lexical-ref loc
+ sym
+ sym))
+ dynamic-syms)
+ (make-body)))))))))))))
+
+;;; Let* is compiled to a cascaded set of "small lets" for each binding
+;;; in turn so that each one already sees the preceding bindings.
+
(define (generate-let* loc module bindings body)
(let ((bind (process-let-bindings loc bindings)))
(begin
(for-each (lambda (sym)
(if (not (bind-lexically? sym module))
- (mark-global-needed! (fluid-ref bindings-data) sym
module)))
+ (mark-global-needed! (fluid-ref bindings-data)
+ sym
+ module)))
(map car bind))
(let iterate ((tail bind))
(if (null? tail)
- (make-sequence loc (map compile-expr body))
- (let ((sym (caar tail))
- (value (compile-expr (cdar tail))))
- (if (bind-lexically? sym module)
- (let ((target (gensym)))
- (make-let loc `(,target) `(,target) `(,value)
- (with-lexical-bindings (fluid-ref bindings-data)
- `(,sym) `(,target)
- (lambda ()
- (iterate (cdr tail))))))
- (let-dynamic loc
- `(,(caar tail)) module `(,value)
- (iterate (cdr tail))))))))))
-
-
-; Split the argument list of a lambda expression into required, optional and
-; rest arguments and also check it is actually valid.
-; Additionally, we create a list of all "local variables" (that is, required,
-; optional and rest arguments together) and also this one split into those to
-; be bound lexically and dynamically.
-; Returned is as multiple values: required optional rest lexical dynamic
+ (make-sequence loc (map compile-expr body))
+ (let ((sym (caar tail))
+ (value (compile-expr (cdar tail))))
+ (if (bind-lexically? sym module)
+ (let ((target (gensym)))
+ (make-let loc
+ `(,target)
+ `(,target)
+ `(,value)
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ `(,sym)
+ `(,target)
+ (lambda () (iterate (cdr tail))))))
+ (let-dynamic loc
+ `(,(caar tail))
+ module
+ `(,value)
+ (iterate (cdr tail))))))))))
+
+;;; Split the argument list of a lambda expression into required,
+;;; optional and rest arguments and also check it is actually valid.
+;;; Additionally, we create a list of all "local variables" (that is,
+;;; required, optional and rest arguments together) and also this one
+;;; split into those to be bound lexically and dynamically. Returned is
+;;; as multiple values: required optional rest lexical dynamic
(define (bind-arg-lexical? arg)
(let ((always (fluid-ref always-lexical)))
@@ -325,47 +372,51 @@
(lexical '())
(dynamic '()))
(cond
-
- ((null? tail)
- (let ((final-required (reverse required))
- (final-optional (reverse optional))
- (final-lexical (reverse lexical))
- (final-dynamic (reverse dynamic)))
- (values final-required final-optional #f
- final-lexical final-dynamic)))
-
- ((and (eq? mode 'required)
- (eq? (car tail) '&optional))
- (iterate (cdr tail) 'optional required optional lexical dynamic))
-
- ((eq? (car tail) '&rest)
- (if (or (null? (cdr tail))
- (not (null? (cddr tail))))
- (report-error loc "expected exactly one symbol after &rest")
- (let* ((rest (cadr tail))
- (rest-lexical (bind-arg-lexical? rest))
- (final-required (reverse required))
- (final-optional (reverse optional))
- (final-lexical (reverse (if rest-lexical
- (cons rest lexical)
- lexical)))
- (final-dynamic (reverse (if rest-lexical
- dynamic
- (cons rest dynamic)))))
- (values final-required final-optional rest
- final-lexical final-dynamic))))
-
- (else
- (if (not (symbol? (car tail)))
- (report-error loc "expected symbol in argument list, got" (car tail))
+ ((null? tail)
+ (let ((final-required (reverse required))
+ (final-optional (reverse optional))
+ (final-lexical (reverse lexical))
+ (final-dynamic (reverse dynamic)))
+ (values final-required
+ final-optional
+ #f
+ final-lexical
+ final-dynamic)))
+ ((and (eq? mode 'required)
+ (eq? (car tail) '&optional))
+ (iterate (cdr tail) 'optional required optional lexical dynamic))
+ ((eq? (car tail) '&rest)
+ (if (or (null? (cdr tail))
+ (not (null? (cddr tail))))
+ (report-error loc "expected exactly one symbol after &rest")
+ (let* ((rest (cadr tail))
+ (rest-lexical (bind-arg-lexical? rest))
+ (final-required (reverse required))
+ (final-optional (reverse optional))
+ (final-lexical (reverse (if rest-lexical
+ (cons rest lexical)
+ lexical)))
+ (final-dynamic (reverse (if rest-lexical
+ dynamic
+ (cons rest dynamic)))))
+ (values final-required
+ final-optional
+ rest
+ final-lexical
+ final-dynamic))))
+ (else
+ (if (not (symbol? (car tail)))
+ (report-error loc
+ "expected symbol in argument list, got"
+ (car tail))
(let* ((arg (car tail))
(bind-lexical (bind-arg-lexical? arg))
(new-lexical (if bind-lexical
- (cons arg lexical)
- lexical))
+ (cons arg lexical)
+ lexical))
(new-dynamic (if bind-lexical
- dynamic
- (cons arg dynamic))))
+ dynamic
+ (cons arg dynamic))))
(case mode
((required) (iterate (cdr tail) mode
(cons arg required) optional
@@ -374,476 +425,487 @@
required (cons arg optional)
new-lexical new-dynamic))
(else
- (error "invalid mode in split-lambda-arguments" mode)))))))))
-
-
-; Compile a lambda expression. Things get a little complicated because TreeIL
-; does not allow optional arguments but only one rest argument, and also the
-; rest argument should be nil instead of '() for no values given. Because of
-; this, we have to do a little preprocessing to get everything done before the
-; real body is called.
-;
-; (lambda (a &optional b &rest c) body) should become:
-; (lambda (a_ . rest_)
-; (with-fluids* (list a b c) (list a_ nil nil)
-; (lambda ()
-; (if (not (null? rest_))
-; (begin
-; (fluid-set! b (car rest_))
-; (set! rest_ (cdr rest_))
-; (if (not (null? rest_))
-; (fluid-set! c rest_))))
-; body)))
-;
-; This is formulated very imperatively, but I think in this case that is quite
-; clear and better than creating a lot of nested let's.
-;
-; Another thing we have to be aware of is that lambda arguments are usually
-; dynamically bound, even when a lexical binding is in tact for a symbol.
-; For symbols that are marked as 'always lexical' however, we bind them here
-; lexically, too -- and thus we get them out of the let-dynamic call and
-; register a lexical binding for them (the lexical target variable is already
-; there, namely the real lambda argument from TreeIL).
-; For optional arguments that are lexically bound we need to create the lexical
-; bindings though with an additional let, as those arguments are not part of
the
-; ordinary argument list.
+ (error "invalid mode in split-lambda-arguments"
+ mode)))))))))
+
+;;; Compile a lambda expression. One thing we have to be aware of is
+;;; that lambda arguments are usually dynamically bound, even when a
+;;; lexical binding is intact for a symbol. For symbols that are marked
+;;; as 'always lexical,' however, we lexically bind here as well, and
+;;; thus we get them out of the let-dynamic call and register a lexical
+;;; binding for them (the lexical target variable is already there,
+;;; namely the real lambda argument from TreeIL).
(define (compile-lambda loc args body)
(if (not (list? args))
- (report-error loc "expected list for argument-list" args))
+ (report-error loc "expected list for argument-list" args))
(if (null? body)
- (report-error loc "function body might not be empty"))
- (call-with-values
- (lambda ()
- (split-lambda-arguments loc args))
- (lambda (required optional rest lexical dynamic)
- (let* ((make-sym (lambda (sym) (gensym)))
- (required-sym (map make-sym required))
- (required-pairs (map cons required required-sym))
- (have-real-rest (or rest (not (null? optional))))
- (rest-sym (if have-real-rest (gensym) '()))
- (rest-name (if rest rest rest-sym))
- (rest-lexical (and rest (memq rest lexical)))
- (rest-dynamic (and rest (not rest-lexical)))
- (real-args (append required-sym rest-sym))
- (arg-names (append required rest-name))
- (lex-optionals (lset-intersection eq? optional lexical))
- (dyn-optionals (lset-intersection eq? optional dynamic))
- (optional-sym (map make-sym lex-optionals))
- (optional-lex-pairs (map cons lex-optionals optional-sym))
- (find-required-pairs (lambda (filter)
- (lset-intersection (lambda (name-sym el)
- (eq? (car name-sym)
- el))
- required-pairs filter)))
- (required-lex-pairs (find-required-pairs lexical))
- (rest-pair (if rest-lexical `((,rest . ,rest-sym)) '()))
- (all-lex-pairs (append required-lex-pairs optional-lex-pairs
- rest-pair)))
- (for-each (lambda (sym)
- (mark-global-needed! (fluid-ref bindings-data)
- sym value-slot))
- dynamic)
- (with-dynamic-bindings (fluid-ref bindings-data) dynamic
+ (report-error loc "function body must not be empty"))
+ (receive (required optional rest lexical dynamic)
+ (split-lambda-arguments loc args)
+ (define (process-args args)
+ (define (find-pairs pairs filter)
+ (lset-intersection (lambda (name+sym x)
+ (eq? (car name+sym) x))
+ pairs
+ filter))
+ (let* ((syms (map (lambda (x) (gensym)) args))
+ (pairs (map cons args syms))
+ (lexical-pairs (find-pairs pairs lexical))
+ (dynamic-pairs (find-pairs pairs dynamic)))
+ (values syms pairs lexical-pairs dynamic-pairs)))
+ (let*-values (((required-syms
+ required-pairs
+ required-lex-pairs
+ required-dyn-pairs)
+ (process-args required))
+ ((optional-syms
+ optional-pairs
+ optional-lex-pairs
+ optional-dyn-pairs)
+ (process-args optional))
+ ((rest-syms rest-pairs rest-lex-pairs rest-dyn-pairs)
+ (process-args (if rest (list rest) '())))
+ ((the-rest-sym) (if rest (car rest-syms) #f))
+ ((all-syms) (append required-syms
+ optional-syms
+ rest-syms))
+ ((all-lex-pairs) (append required-lex-pairs
+ optional-lex-pairs
+ rest-lex-pairs))
+ ((all-dyn-pairs) (append required-dyn-pairs
+ optional-dyn-pairs
+ rest-dyn-pairs)))
+ (for-each (lambda (sym)
+ (mark-global-needed! (fluid-ref bindings-data)
+ sym
+ value-slot))
+ dynamic)
+ (with-dynamic-bindings
+ (fluid-ref bindings-data)
+ dynamic
+ (lambda ()
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ (map car all-lex-pairs)
+ (map cdr all-lex-pairs)
(lambda ()
- (with-lexical-bindings (fluid-ref bindings-data)
- (map car all-lex-pairs)
- (map cdr all-lex-pairs)
- (lambda ()
- (make-lambda loc '()
- (make-lambda-case
- #f required #f
- (if have-real-rest rest-name #f)
- #f '()
- (if have-real-rest
- (append required-sym (list rest-sym))
- required-sym)
- (let* ((init-req (map (lambda (name-sym)
- (make-lexical-ref loc (car name-sym)
- (cdr
name-sym)))
- (find-required-pairs dynamic)))
- (init-nils (map (lambda (sym) (nil-value loc))
- (if rest-dynamic
- `(,@dyn-optionals ,rest-sym)
- dyn-optionals)))
- (init (append init-req init-nils))
- (func-body (make-sequence loc
- `(,(process-optionals loc optional
- rest-name rest-sym)
- ,(process-rest loc rest
- rest-name rest-sym)
- ,@(map compile-expr body))))
- (dynlet (let-dynamic loc dynamic value-slot
- init func-body))
- (full-body (if (null? dynamic) func-body dynlet)))
- (if (null? optional-sym)
- full-body
- (make-let loc
- optional-sym optional-sym
- (map (lambda (sym) (nil-value loc)) optional-sym)
- full-body)))
- #f))))))))))
-
-; Build the code to handle setting of optional arguments that are present
-; and updating the rest list.
-(define (process-optionals loc optional rest-name rest-sym)
- (let iterate ((tail optional))
- (if (null? tail)
- (make-void loc)
- (make-conditional loc
- (call-primitive loc 'null? (make-lexical-ref loc rest-name rest-sym))
- (make-void loc)
- (make-sequence loc
- (list (set-variable! loc (car tail) value-slot
- (call-primitive loc 'car
- (make-lexical-ref loc rest-name rest-sym)))
- (make-lexical-set loc rest-name rest-sym
- (call-primitive loc 'cdr
- (make-lexical-ref loc rest-name rest-sym)))
- (iterate (cdr tail))))))))
-
-; This builds the code to set the rest variable to nil if it is empty.
-(define (process-rest loc rest rest-name rest-sym)
- (let ((rest-empty (call-primitive loc 'null?
- (make-lexical-ref loc rest-name
rest-sym))))
- (cond
- (rest
- (make-conditional loc rest-empty
- (make-void loc)
- (set-variable! loc rest value-slot
- (make-lexical-ref loc rest-name rest-sym))))
- ((not (null? rest-sym))
- (make-conditional loc rest-empty
- (make-void loc)
- (runtime-error loc "too many arguments and no rest argument")))
- (else (make-void loc)))))
-
-
-; Handle the common part of defconst and defvar, that is, checking for a
correct
-; doc string and arguments as well as maybe in the future handling the
docstring
-; somehow.
+ (make-lambda
+ loc
+ '()
+ (make-lambda-case
+ #f
+ required
+ optional
+ rest
+ #f
+ (map (lambda (x) (nil-value loc)) optional)
+ all-syms
+ (let ((compiled-body
+ (make-sequence loc (map compile-expr body))))
+ (make-sequence
+ loc
+ (list
+ (if rest
+ (make-conditional
+ loc
+ (call-primitive loc
+ 'null?
+ (make-lexical-ref loc
+ rest
+ the-rest-sym))
+ (make-lexical-set loc
+ rest
+ the-rest-sym
+ (nil-value loc))
+ (make-void loc))
+ (make-void loc))
+ (if (null? dynamic)
+ compiled-body
+ (let-dynamic loc
+ dynamic
+ value-slot
+ (map (lambda (name-sym)
+ (make-lexical-ref
+ loc
+ (car name-sym)
+ (cdr name-sym)))
+ all-dyn-pairs)
+ compiled-body)))))
+ #f)))))))))
+
+;;; Handle the common part of defconst and defvar, that is, checking for
+;;; a correct doc string and arguments as well as maybe in the future
+;;; handling the docstring somehow.
(define (handle-var-def loc sym doc)
(cond
- ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
- ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
- ((and (not (null? doc)) (not (string? (car doc))))
- (report-error loc "expected string as third argument of defvar, got"
- (car doc)))
- ; TODO: Handle doc string if present.
- (else #t)))
-
-
-; Handle macro bindings.
-
-(define (is-macro? sym)
- (module-defined? (resolve-interface macro-slot) sym))
-
-(define (define-macro! loc sym definition)
- (let ((resolved (resolve-module macro-slot)))
- (if (is-macro? sym)
- (report-error loc "macro is already defined" sym)
- (begin
- (module-define! resolved sym definition)
- (module-export! resolved (list sym))))))
-
-(define (get-macro sym)
- (module-ref (resolve-module macro-slot) sym))
-
-
-; See if a (backquoted) expression contains any unquotes.
+ ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
+ ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
+ ((and (not (null? doc)) (not (string? (car doc))))
+ (report-error loc "expected string as third argument of defvar, got"
+ (car doc)))
+ ;; TODO: Handle doc string if present.
+ (else #t)))
+
+;;; Handle macro and special operator bindings.
+
+(define (find-operator sym type)
+ (and
+ (symbol? sym)
+ (module-defined? (resolve-interface function-slot) sym)
+ (let* ((op (module-ref (resolve-module function-slot) sym))
+ (op (if (fluid? op) (fluid-ref op) op)))
+ (if (and (pair? op) (eq? (car op) type))
+ (cdr op)
+ #f))))
+
+;;; See if a (backquoted) expression contains any unquotes.
(define (contains-unquotes? expr)
(if (pair? expr)
- (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
- #t
- (or (contains-unquotes? (car expr))
- (contains-unquotes? (cdr expr))))
- #f))
-
-
-; Process a backquoted expression by building up the needed cons/append calls.
-; For splicing, it is assumed that the expression spliced in evaluates to a
-; list. The emacs manual does not really state either it has to or what to do
-; if it does not, but Scheme explicitly forbids it and this seems reasonable
-; also for elisp.
+ (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
+ #t
+ (or (contains-unquotes? (car expr))
+ (contains-unquotes? (cdr expr))))
+ #f))
+
+;;; Process a backquoted expression by building up the needed
+;;; cons/append calls. For splicing, it is assumed that the expression
+;;; spliced in evaluates to a list. The emacs manual does not really
+;;; state either it has to or what to do if it does not, but Scheme
+;;; explicitly forbids it and this seems reasonable also for elisp.
(define (unquote-cell? expr)
(and (list? expr) (= (length expr) 2) (unquote? (car expr))))
+
(define (unquote-splicing-cell? expr)
(and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr))))
(define (process-backquote loc expr)
(if (contains-unquotes? expr)
- (if (pair? expr)
- (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
- (compile-expr (cadr expr))
- (let* ((head (car expr))
- (processed-tail (process-backquote loc (cdr expr)))
- (head-is-list-2 (and (list? head) (= (length head) 2)))
- (head-unquote (and head-is-list-2 (unquote? (car head))))
- (head-unquote-splicing (and head-is-list-2
- (unquote-splicing? (car head)))))
- (if head-unquote-splicing
- (call-primitive loc 'append
- (compile-expr (cadr head)) processed-tail)
- (call-primitive loc 'cons
- (if head-unquote
- (compile-expr (cadr head))
- (process-backquote loc head))
- processed-tail))))
- (report-error loc "non-pair expression contains unquotes" expr))
- (make-const loc expr)))
-
-
-; Temporarily update a list of symbols that are handled specially (disabled
-; void check or always lexical) for compiling body.
-; We need to handle special cases for already all / set to all and the like.
+ (if (pair? expr)
+ (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
+ (compile-expr (cadr expr))
+ (let* ((head (car expr))
+ (processed-tail (process-backquote loc (cdr expr)))
+ (head-is-list-2 (and (list? head)
+ (= (length head) 2)))
+ (head-unquote (and head-is-list-2
+ (unquote? (car head))))
+ (head-unquote-splicing (and head-is-list-2
+ (unquote-splicing?
+ (car head)))))
+ (if head-unquote-splicing
+ (call-primitive loc
+ 'append
+ (compile-expr (cadr head))
+ processed-tail)
+ (call-primitive loc 'cons
+ (if head-unquote
+ (compile-expr (cadr head))
+ (process-backquote loc head))
+ processed-tail))))
+ (report-error loc
+ "non-pair expression contains unquotes"
+ expr))
+ (make-const loc expr)))
+
+;;; Temporarily update a list of symbols that are handled specially
+;;; (disabled void check or always lexical) for compiling body. We need
+;;; to handle special cases for already all / set to all and the like.
(define (with-added-symbols loc fluid syms body)
(if (null? body)
- (report-error loc "symbol-list construct has empty body"))
+ (report-error loc "symbol-list construct has empty body"))
(if (not (or (eq? syms 'all)
(and (list? syms) (and-map symbol? syms))))
- (report-error loc "invalid symbol list" syms))
+ (report-error loc "invalid symbol list" syms))
(let ((old (fluid-ref fluid))
(make-body (lambda ()
(make-sequence loc (map compile-expr body)))))
(if (eq? old 'all)
- (make-body)
- (let ((new (if (eq? syms 'all)
- 'all
- (append syms old))))
- (with-fluids ((fluid new))
- (make-body))))))
-
-
-; Compile a symbol expression. This is a variable reference or maybe some
-; special value like nil.
-
-(define (compile-symbol loc sym)
- (case sym
- ((nil) (nil-value loc))
- ((t) (t-value loc))
- (else (reference-with-check loc sym value-slot))))
-
-
-; Compile a pair-expression (that is, any structure-like construct).
-
-(define (compile-pair loc expr)
- (pmatch expr
-
- ((progn . ,forms)
- (make-sequence loc (map compile-expr forms)))
-
- ((if ,condition ,ifclause)
- (make-conditional loc (compile-expr condition)
- (compile-expr ifclause)
- (nil-value loc)))
- ((if ,condition ,ifclause ,elseclause)
- (make-conditional loc (compile-expr condition)
- (compile-expr ifclause)
- (compile-expr elseclause)))
- ((if ,condition ,ifclause . ,elses)
- (make-conditional loc (compile-expr condition)
- (compile-expr ifclause)
- (make-sequence loc (map compile-expr elses))))
-
- ; defconst and defvar are kept here in the compiler (rather than doing them
- ; as macros) for if we may want to handle the docstring somehow.
-
- ((defconst ,sym ,value . ,doc)
+ (make-body)
+ (let ((new (if (eq? syms 'all)
+ 'all
+ (append syms old))))
+ (with-fluids ((fluid new))
+ (make-body))))))
+
+;;; Special operators
+
+(defspecial progn (loc args)
+ (make-sequence loc (map compile-expr args)))
+
+(defspecial if (loc args)
+ (pmatch args
+ ((,cond ,then . ,else)
+ (make-conditional loc
+ (compile-expr cond)
+ (compile-expr then)
+ (if (null? else)
+ (nil-value loc)
+ (make-sequence loc
+ (map compile-expr else)))))))
+
+(defspecial defconst (loc args)
+ (pmatch args
+ ((,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
- (make-sequence loc
- (list (set-variable! loc sym value-slot (compile-expr value))
- (make-const loc sym)))))
-
- ((defvar ,sym) (make-const loc sym))
- ((defvar ,sym ,value . ,doc)
+ (make-sequence loc
+ (list (set-variable! loc
+ sym
+ value-slot
+ (compile-expr value))
+ (make-const loc sym)))))))
+
+(defspecial defvar (loc args)
+ (pmatch args
+ ((,sym) (make-const loc sym))
+ ((,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
- (make-sequence loc
- (list (make-conditional loc
- (call-primitive loc 'eq?
- (make-module-ref loc runtime 'void #t)
- (reference-variable loc sym value-slot))
- (set-variable! loc sym value-slot
- (compile-expr value))
- (make-void loc))
- (make-const loc sym)))))
-
- ; Build a set form for possibly multiple values. The code is not
formulated
- ; tail recursive because it is clearer this way and large lists of symbol
- ; expression pairs are very unlikely.
- ((setq . ,args) (guard (not (null? args)))
- (make-sequence loc
- (let iterate ((tail args))
- (let ((sym (car tail))
- (tailtail (cdr tail)))
+ (make-sequence
+ loc
+ (list
+ (make-conditional
+ loc
+ (make-conditional
+ loc
+ (call-primitive
+ loc
+ 'module-bound?
+ (call-primitive loc
+ 'resolve-interface
+ (make-const loc value-slot))
+ (make-const loc sym))
+ (call-primitive loc
+ 'fluid-bound?
+ (make-module-ref loc value-slot sym #t))
+ (make-const loc #f))
+ (make-void loc)
+ (set-variable! loc sym value-slot (compile-expr value)))
+ (make-const loc sym)))))))
+
+(defspecial setq (loc args)
+ (define (car* x) (if (null? x) '() (car x)))
+ (define (cdr* x) (if (null? x) '() (cdr x)))
+ (define (cadr* x) (car* (cdr* x)))
+ (define (cddr* x) (cdr* (cdr* x)))
+ (make-sequence
+ loc
+ (let loop ((args args) (last (nil-value loc)))
+ (if (null? args)
+ (list last)
+ (let ((sym (car args))
+ (val (compile-expr (cadr* args))))
(if (not (symbol? sym))
- (report-error loc "expected symbol in setq")
- (if (null? tailtail)
- (report-error loc "missing value for symbol in setq" sym)
- (let* ((val (compile-expr (car tailtail)))
- (op (set-variable! loc sym value-slot val)))
- (if (null? (cdr tailtail))
- (let* ((temp (gensym))
- (ref (make-lexical-ref loc temp temp)))
- (list (make-let loc `(,temp) `(,temp) `(,val)
- (make-sequence loc
- (list (set-variable! loc sym value-slot ref)
- ref)))))
- (cons (set-variable! loc sym value-slot val)
- (iterate (cdr tailtail)))))))))))
-
- ; All lets (let, flet, lexical-let and let* forms) are done using the
- ; generate-let/generate-let* methods.
-
- ((let ,bindings . ,body) (guard (and (list? bindings)
- (not (null? bindings))
- (not (null? body))))
- (generate-let loc value-slot bindings body))
- ((lexical-let ,bindings . ,body) (guard (and (list? bindings)
- (not (null? bindings))
- (not (null? body))))
- (generate-let loc 'lexical bindings body))
- ((flet ,bindings . ,body) (guard (and (list? bindings)
- (not (null? bindings))
- (not (null? body))))
- (generate-let loc function-slot bindings body))
-
- ((let* ,bindings . ,body) (guard (and (list? bindings)
- (not (null? bindings))
- (not (null? body))))
- (generate-let* loc value-slot bindings body))
- ((lexical-let* ,bindings . ,body) (guard (and (list? bindings)
- (not (null? bindings))
- (not (null? body))))
- (generate-let* loc 'lexical bindings body))
- ((flet* ,bindings . ,body) (guard (and (list? bindings)
- (not (null? bindings))
- (not (null? body))))
- (generate-let* loc function-slot bindings body))
-
- ; Temporarily disable void checks or set symbols as always lexical only
- ; for the lexical scope of a construct.
-
- ((without-void-checks ,syms . ,body)
- (with-added-symbols loc disable-void-check syms body))
-
- ((with-always-lexical ,syms . ,body)
- (with-added-symbols loc always-lexical syms body))
-
- ; guile-ref allows building TreeIL's module references from within
- ; elisp as a way to access data within
- ; the Guile universe. The module and symbol referenced are static values,
- ; just like (@ module symbol) does!
- ((guile-ref ,module ,sym) (guard (and (list? module) (symbol? sym)))
- (make-module-ref loc module sym #t))
-
- ; guile-primitive allows to create primitive references, which are still
- ; a little faster.
- ((guile-primitive ,sym) (guard (symbol? sym))
- (make-primitive-ref loc sym))
-
- ; A while construct is transformed into a tail-recursive loop like this:
- ; (letrec ((iterate (lambda ()
- ; (if condition
- ; (begin body
- ; (iterate))
- ; #nil))))
- ; (iterate))
- ;
- ; As letrec is not directly accessible from elisp, while is implemented
here
- ; instead of with a macro.
- ((while ,condition . ,body)
+ (report-error loc "expected symbol in setq")
+ (cons
+ (set-variable! loc sym value-slot val)
+ (loop (cddr* args)
+ (reference-variable loc sym value-slot)))))))))
+
+(defspecial let (loc args)
+ (pmatch args
+ ((,bindings . ,body)
+ (generate-let loc value-slot bindings body))))
+
+(defspecial lexical-let (loc args)
+ (pmatch args
+ ((,bindings . ,body)
+ (generate-let loc 'lexical bindings body))))
+
+(defspecial flet (loc args)
+ (pmatch args
+ ((,bindings . ,body)
+ (generate-let loc function-slot bindings body))))
+
+(defspecial let* (loc args)
+ (pmatch args
+ ((,bindings . ,body)
+ (generate-let* loc value-slot bindings body))))
+
+(defspecial lexical-let* (loc args)
+ (pmatch args
+ ((,bindings . ,body)
+ (generate-let* loc 'lexical bindings body))))
+
+(defspecial flet* (loc args)
+ (pmatch args
+ ((,bindings . ,body)
+ (generate-let* loc function-slot bindings body))))
+
+;;; Temporarily set symbols as always lexical only for the lexical scope
+;;; of a construct.
+
+(defspecial with-always-lexical (loc args)
+ (pmatch args
+ ((,syms . ,body)
+ (with-added-symbols loc always-lexical syms body))))
+
+;;; guile-ref allows building TreeIL's module references from within
+;;; elisp as a way to access data within the Guile universe. The module
+;;; and symbol referenced are static values, just like (@ module symbol)
+;;; does!
+
+(defspecial guile-ref (loc args)
+ (pmatch args
+ ((,module ,sym) (guard (and (list? module) (symbol? sym)))
+ (make-module-ref loc module sym #t))))
+
+;;; guile-primitive allows to create primitive references, which are
+;;; still a little faster.
+
+(defspecial guile-primitive (loc args)
+ (pmatch args
+ ((,sym)
+ (make-primitive-ref loc sym))))
+
+;;; A while construct is transformed into a tail-recursive loop like
+;;; this:
+;;;
+;;; (letrec ((iterate (lambda ()
+;;; (if condition
+;;; (begin body
+;;; (iterate))
+;;; #nil))))
+;;; (iterate))
+;;;
+;;; As letrec is not directly accessible from elisp, while is
+;;; implemented here instead of with a macro.
+
+(defspecial while (loc args)
+ (pmatch args
+ ((,condition . ,body)
(let* ((itersym (gensym))
(compiled-body (map compile-expr body))
(iter-call (make-application loc
- (make-lexical-ref loc 'iterate itersym)
- (list)))
+ (make-lexical-ref loc
+ 'iterate
+ itersym)
+ (list)))
(full-body (make-sequence loc
- `(,@compiled-body ,iter-call)))
+ `(,@compiled-body ,iter-call)))
(lambda-body (make-conditional loc
- (compile-expr condition)
- full-body
- (nil-value loc)))
- (iter-thunk (make-lambda loc '()
- (make-lambda-case #f '() #f #f #f '() '()
- lambda-body #f))))
- (make-letrec loc #f '(iterate) (list itersym) (list iter-thunk)
- iter-call)))
-
- ; Either (lambda ...) or (function (lambda ...)) denotes a
lambda-expression
- ; that should be compiled.
- ((lambda ,args . ,body)
- (compile-lambda loc args body))
- ((function (lambda ,args . ,body))
+ (compile-expr condition)
+ full-body
+ (nil-value loc)))
+ (iter-thunk (make-lambda loc
+ '()
+ (make-lambda-case #f
+ '()
+ #f
+ #f
+ #f
+ '()
+ '()
+ lambda-body
+ #f))))
+ (make-letrec loc
+ #f
+ '(iterate)
+ (list itersym)
+ (list iter-thunk)
+ iter-call)))))
+
+(defspecial function (loc args)
+ (pmatch args
+ (((lambda ,args . ,body))
(compile-lambda loc args body))
+ ((,sym) (guard (symbol? sym))
+ (reference-variable loc sym function-slot))))
- ; Build a lambda and also assign it to the function cell of some symbol.
- ; This is no macro as we might want to honour the docstring at some time;
- ; just as with defvar/defconst.
- ((defun ,name ,args . ,body)
+(defspecial defmacro (loc args)
+ (pmatch args
+ ((,name ,args . ,body)
(if (not (symbol? name))
- (report-error loc "expected symbol as function name" name)
- (make-sequence loc
- (list (set-variable! loc name function-slot
- (compile-lambda loc args body))
- (make-const loc name)))))
-
- ; Define a macro (this is done directly at compile-time!).
- ; FIXME: Recursive macros don't work!
- ((defmacro ,name ,args . ,body)
+ (report-error loc "expected symbol as macro name" name)
+ (let* ((tree-il
+ (make-sequence
+ loc
+ (list
+ (set-variable!
+ loc
+ name
+ function-slot
+ (make-application
+ loc
+ (make-module-ref loc '(guile) 'cons #t)
+ (list (make-const loc 'macro)
+ (compile-lambda loc args body))))
+ (make-const loc name)))))
+ (compile (ensuring-globals loc bindings-data tree-il)
+ #:from 'tree-il
+ #:to 'value)
+ tree-il)))))
+
+(defspecial defun (loc args)
+ (pmatch args
+ ((,name ,args . ,body)
(if (not (symbol? name))
- (report-error loc "expected symbol as macro name" name)
- (let* ((tree-il (with-fluids ((bindings-data (make-bindings)))
- (compile-lambda loc args body)))
- (object (compile tree-il #:from 'tree-il #:to 'value)))
- (define-macro! loc name object)
- (make-const loc name))))
-
- ; XXX: Maybe we could implement backquotes in macros, too.
- ((,backq ,val) (guard (backquote? backq))
- (process-backquote loc val))
-
- ; XXX: Why do we need 'quote here instead of quote?
- (('quote ,val)
- (make-const loc val))
-
- ; Macro calls are simply expanded and recursively compiled.
- ((,macro . ,args) (guard (and (symbol? macro) (is-macro? macro)))
- (let ((expander (get-macro macro)))
- (compile-expr (apply expander args))))
-
- ; Function calls using (function args) standard notation; here, we have to
- ; take the function value of a symbol if it is one. It seems that
functions
- ; in form of uncompiled lists are not supported in this syntax, so we don't
- ; have to care for them.
- ((,func . ,args)
- (make-application loc
- (if (symbol? func)
- (reference-with-check loc func function-slot)
- (compile-expr func))
- (map compile-expr args)))
-
- (else
- (report-error loc "unrecognized elisp" expr))))
-
-
-; Compile a single expression to TreeIL.
+ (report-error loc "expected symbol as function name" name)
+ (make-sequence loc
+ (list (set-variable! loc
+ name
+ function-slot
+ (compile-lambda loc
+ args
+ body))
+ (make-const loc name)))))))
+
+(defspecial #{`}# (loc args)
+ (pmatch args
+ ((,val)
+ (process-backquote loc val))))
+
+(defspecial quote (loc args)
+ (pmatch args
+ ((,val)
+ (make-const loc val))))
+
+;;; Compile a compound expression to Tree-IL.
+
+(define (compile-pair loc expr)
+ (let ((operator (car expr))
+ (arguments (cdr expr)))
+ (cond
+ ((find-operator operator 'special-operator)
+ => (lambda (special-operator-function)
+ (special-operator-function loc arguments)))
+ ((find-operator operator 'macro)
+ => (lambda (macro-function)
+ (compile-expr (apply macro-function arguments))))
+ (else
+ (make-application loc
+ (if (symbol? operator)
+ (reference-variable loc
+ operator
+ function-slot)
+ (compile-expr operator))
+ (map compile-expr arguments))))))
+
+;;; Compile a symbol expression. This is a variable reference or maybe
+;;; some special value like nil.
+
+(define (compile-symbol loc sym)
+ (case sym
+ ((nil) (nil-value loc))
+ ((t) (t-value loc))
+ (else (reference-variable loc sym value-slot))))
+
+;;; Compile a single expression to TreeIL.
(define (compile-expr expr)
(let ((loc (location expr)))
(cond
- ((symbol? expr)
- (compile-symbol loc expr))
- ((pair? expr)
- (compile-pair loc expr))
- (else (make-const loc expr)))))
-
+ ((symbol? expr)
+ (compile-symbol loc expr))
+ ((pair? expr)
+ (compile-pair loc expr))
+ (else (make-const loc expr)))))
-; Process the compiler options.
-; FIXME: Why is '(()) passed as options by the REPL?
+;;; Process the compiler options.
+;;; FIXME: Why is '(()) passed as options by the REPL?
(define (valid-symbol-list-arg? value)
(or (eq? value 'all)
@@ -852,39 +914,35 @@
(define (process-options! opt)
(if (and (not (null? opt))
(not (equal? opt '(()))))
- (if (null? (cdr opt))
- (report-error #f "Invalid compiler options" opt)
- (let ((key (car opt))
- (value (cadr opt)))
- (case key
- ((#:disable-void-check)
- (if (valid-symbol-list-arg? value)
- (fluid-set! disable-void-check value)
- (report-error #f "Invalid value for #:disable-void-check" value)))
- ((#:always-lexical)
- (if (valid-symbol-list-arg? value)
- (fluid-set! always-lexical value)
- (report-error #f "Invalid value for #:always-lexical" value)))
- (else (report-error #f "Invalid compiler option" key)))))))
-
-
-; Entry point for compilation to TreeIL.
-; This creates the bindings data structure, and after compiling the main
-; expression we need to make sure all globals for symbols used during the
-; compilation are created using the generate-ensure-global function.
+ (if (null? (cdr opt))
+ (report-error #f "Invalid compiler options" opt)
+ (let ((key (car opt))
+ (value (cadr opt)))
+ (case key
+ ((#:warnings) ; ignore
+ #f)
+ ((#:always-lexical)
+ (if (valid-symbol-list-arg? value)
+ (fluid-set! always-lexical value)
+ (report-error #f
+ "Invalid value for #:always-lexical"
+ value)))
+ (else (report-error #f
+ "Invalid compiler option"
+ key)))))))
+
+;;; Entry point for compilation to TreeIL. This creates the bindings
+;;; data structure, and after compiling the main expression we need to
+;;; make sure all globals for symbols used during the compilation are
+;;; created using the generate-ensure-global function.
(define (compile-tree-il expr env opts)
(values
- (with-fluids ((bindings-data (make-bindings))
- (disable-void-check '())
- (always-lexical '()))
- (process-options! opts)
- (let ((loc (location expr))
- (compiled (compile-expr expr)))
- (make-sequence loc
- `(,@(map-globals-needed (fluid-ref bindings-data)
- (lambda (mod sym)
- (generate-ensure-global loc sym mod)))
- ,compiled))))
- env
- env))
+ (with-fluids ((bindings-data (make-bindings))
+ (disable-void-check '())
+ (always-lexical '()))
+ (process-options! opts)
+ (let ((compiled (compile-expr expr)))
+ (ensuring-globals (location expr) bindings-data compiled)))
+ env
+ env))
diff --git a/module/language/elisp/lexer.scm b/module/language/elisp/lexer.scm
index 758b277..ed6c5f8 100644
--- a/module/language/elisp/lexer.scm
+++ b/module/language/elisp/lexer.scm
@@ -1,6 +1,6 @@
;;; Guile Emacs Lisp
-;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -22,173 +22,179 @@
#:use-module (ice-9 regex)
#:export (get-lexer get-lexer/1))
-; This is the lexical analyzer for the elisp reader. It is hand-written
-; instead of using some generator. I think this is the best solution
-; because of all that fancy escape sequence handling and the like.
-
-; Characters are handled internally as integers representing their
-; code value. This is necessary because elisp allows a lot of fancy modifiers
-; that set certain high-range bits and the resulting values would not fit
-; into a real Scheme character range. Additionally, elisp wants characters
-; as integers, so we just do the right thing...
-
-; TODO: address@hidden comments
-
+;;; This is the lexical analyzer for the elisp reader. It is
+;;; hand-written instead of using some generator. I think this is the
+;;; best solution because of all that fancy escape sequence handling and
+;;; the like.
+;;;
+;;; Characters are handled internally as integers representing their
+;;; code value. This is necessary because elisp allows a lot of fancy
+;;; modifiers that set certain high-range bits and the resulting values
+;;; would not fit into a real Scheme character range. Additionally,
+;;; elisp wants characters as integers, so we just do the right thing...
+;;;
+;;; TODO: address@hidden comments
-; Report an error from the lexer (that is, invalid input given).
+;;; Report an error from the lexer (that is, invalid input given).
(define (lexer-error port msg . args)
(apply error msg args))
-
-; In a character, set a given bit. This is just some bit-wise or'ing on the
-; characters integer code and converting back to character.
+;;; In a character, set a given bit. This is just some bit-wise or'ing
+;;; on the characters integer code and converting back to character.
(define (set-char-bit chr bit)
(logior chr (ash 1 bit)))
-
-; Check if a character equals some other. This is just like char=? except that
-; the tested one could be EOF in which case it simply isn't equal.
+;;; Check if a character equals some other. This is just like char=?
+;;; except that the tested one could be EOF in which case it simply
+;;; isn't equal.
(define (is-char? tested should-be)
(and (not (eof-object? tested))
(char=? tested should-be)))
-
-; For a character (as integer code), find the real character it represents or
-; #\nul if out of range. This is used to work with Scheme character functions
-; like char-numeric?.
+;;; For a character (as integer code), find the real character it
+;;; represents or #\nul if out of range. This is used to work with
+;;; Scheme character functions like char-numeric?.
(define (real-character chr)
(if (< chr 256)
- (integer->char chr)
- #\nul))
-
+ (integer->char chr)
+ #\nul))
-; Return the control modified version of a character. This is not just setting
-; a modifier bit, because ASCII conrol characters must be handled as such, and
-; in elisp C-? is the delete character for historical reasons.
-; Otherwise, we set bit 26.
+;;; Return the control modified version of a character. This is not
+;;; just setting a modifier bit, because ASCII conrol characters must be
+;;; handled as such, and in elisp C-? is the delete character for
+;;; historical reasons. Otherwise, we set bit 26.
(define (add-control chr)
(let ((real (real-character chr)))
(if (char-alphabetic? real)
- (- (char->integer (char-upcase real)) (char->integer #\@))
- (case real
- ((#\?) 127)
- ((#\@) 0)
- (else (set-char-bit chr 26))))))
-
-
-; Parse a charcode given in some base, basically octal or hexadecimal are
-; needed. A requested number of digits can be given (#f means it does
-; not matter and arbitrary many are allowed), and additionally early
-; return allowed (if fewer valid digits are found).
-; These options are all we need to handle the \u, \U, \x and \ddd (octal
digits)
-; escape sequences.
+ (- (char->integer (char-upcase real)) (char->integer #\@))
+ (case real
+ ((#\?) 127)
+ ((#\@) 0)
+ (else (set-char-bit chr 26))))))
+
+;;; Parse a charcode given in some base, basically octal or hexadecimal
+;;; are needed. A requested number of digits can be given (#f means it
+;;; does not matter and arbitrary many are allowed), and additionally
+;;; early return allowed (if fewer valid digits are found). These
+;;; options are all we need to handle the \u, \U, \x and \ddd (octal
+;;; digits) escape sequences.
(define (charcode-escape port base digits early-return)
(let iterate ((result 0)
(procdigs 0))
(if (and digits (>= procdigs digits))
- result
- (let* ((cur (read-char port))
- (value (cond
- ((char-numeric? cur)
- (- (char->integer cur) (char->integer #\0)))
- ((char-alphabetic? cur)
- (let ((code (- (char->integer (char-upcase cur))
- (char->integer #\A))))
- (if (< code 0)
- #f
- (+ code 10))))
- (else #f)))
- (valid (and value (< value base))))
- (if (not valid)
- (if (or (not digits) early-return)
- (begin
- (unread-char cur port)
- result)
- (lexer-error port "invalid digit in escape-code" base cur))
- (iterate (+ (* result base) value) (1+ procdigs)))))))
-
-
-; Read a character and process escape-sequences when necessary. The special
-; in-string argument defines if this character is part of a string literal or
-; a single character literal, the difference being that in strings the
-; meta modifier sets bit 7, while it is bit 27 for characters.
+ result
+ (let* ((cur (read-char port))
+ (value (cond
+ ((char-numeric? cur)
+ (- (char->integer cur) (char->integer #\0)))
+ ((char-alphabetic? cur)
+ (let ((code (- (char->integer (char-upcase cur))
+ (char->integer #\A))))
+ (if (< code 0)
+ #f
+ (+ code 10))))
+ (else #f)))
+ (valid (and value (< value base))))
+ (if (not valid)
+ (if (or (not digits) early-return)
+ (begin
+ (unread-char cur port)
+ result)
+ (lexer-error port
+ "invalid digit in escape-code"
+ base
+ cur))
+ (iterate (+ (* result base) value) (1+ procdigs)))))))
+
+;;; Read a character and process escape-sequences when necessary. The
+;;; special in-string argument defines if this character is part of a
+;;; string literal or a single character literal, the difference being
+;;; that in strings the meta modifier sets bit 7, while it is bit 27 for
+;;; characters.
(define basic-escape-codes
- '((#\a . 7) (#\b . 8) (#\t . 9)
- (#\n . 10) (#\v . 11) (#\f . 12) (#\r . 13)
- (#\e . 27) (#\s . 32) (#\d . 127)))
+ '((#\a . 7)
+ (#\b . 8)
+ (#\t . 9)
+ (#\n . 10)
+ (#\v . 11)
+ (#\f . 12)
+ (#\r . 13)
+ (#\e . 27)
+ (#\s . 32)
+ (#\d . 127)))
(define (get-character port in-string)
- (let ((meta-bits `((#\A . 22) (#\s . 23) (#\H . 24)
- (#\S . 25) (#\M . ,(if in-string 7 27))))
+ (let ((meta-bits `((#\A . 22)
+ (#\s . 23)
+ (#\H . 24)
+ (#\S . 25)
+ (#\M . ,(if in-string 7 27))))
(cur (read-char port)))
(if (char=? cur #\\)
-
- ; Handle an escape-sequence.
- (let* ((escaped (read-char port))
- (esc-code (assq-ref basic-escape-codes escaped))
- (meta (assq-ref meta-bits escaped)))
- (cond
-
- ; Meta-check must be before esc-code check because \s- must be
- ; recognized as the super-meta modifier if a - follows.
- ; If not, it will be caught as \s -> space escape code.
- ((and meta (is-char? (peek-char port) #\-))
- (if (not (char=? (read-char port) #\-))
- (error "expected - after control sequence"))
- (set-char-bit (get-character port in-string) meta))
-
- ; One of the basic control character escape names?
- (esc-code esc-code)
-
- ; Handle \ddd octal code if it is one.
- ((and (char>=? escaped #\0) (char<? escaped #\8))
- (begin
- (unread-char escaped port)
- (charcode-escape port 8 3 #t)))
-
- ; Check for some escape-codes directly or otherwise
- ; use the escaped character literally.
- (else
+ ;; Handle an escape-sequence.
+ (let* ((escaped (read-char port))
+ (esc-code (assq-ref basic-escape-codes escaped))
+ (meta (assq-ref meta-bits escaped)))
+ (cond
+ ;; Meta-check must be before esc-code check because \s- must
+ ;; be recognized as the super-meta modifier if a - follows.
+ ;; If not, it will be caught as \s -> space escape code.
+ ((and meta (is-char? (peek-char port) #\-))
+ (if (not (char=? (read-char port) #\-))
+ (error "expected - after control sequence"))
+ (set-char-bit (get-character port in-string) meta))
+ ;; One of the basic control character escape names?
+ (esc-code esc-code)
+ ;; Handle \ddd octal code if it is one.
+ ((and (char>=? escaped #\0) (char<? escaped #\8))
+ (begin
+ (unread-char escaped port)
+ (charcode-escape port 8 3 #t)))
+ ;; Check for some escape-codes directly or otherwise use the
+ ;; escaped character literally.
+ (else
(case escaped
((#\^) (add-control (get-character port in-string)))
((#\C)
(if (is-char? (peek-char port) #\-)
- (begin
- (if (not (char=? (read-char port) #\-))
- (error "expected - after control sequence"))
- (add-control (get-character port in-string)))
- escaped))
+ (begin
+ (if (not (char=? (read-char port) #\-))
+ (error "expected - after control sequence"))
+ (add-control (get-character port in-string)))
+ escaped))
((#\x) (charcode-escape port 16 #f #t))
((#\u) (charcode-escape port 16 4 #f))
((#\U) (charcode-escape port 16 8 #f))
(else (char->integer escaped))))))
-
- ; No escape-sequence, just the literal character.
- ; But remember to get the code instead!
- (char->integer cur))))
-
-
-; Read a symbol or number from a port until something follows that marks the
-; start of a new token (like whitespace or parentheses). The data read is
-; returned as a string for further conversion to the correct type, but we also
-; return what this is (integer/float/symbol).
-; If any escaped character is found, it must be a symbol. Otherwise we
-; at the end check the result-string against regular expressions to determine
-; if it is possibly an integer or a float.
+ ;; No escape-sequence, just the literal character. But remember
+ ;; to get the code instead!
+ (char->integer cur))))
+
+;;; Read a symbol or number from a port until something follows that
+;;; marks the start of a new token (like whitespace or parentheses).
+;;; The data read is returned as a string for further conversion to the
+;;; correct type, but we also return what this is
+;;; (integer/float/symbol). If any escaped character is found, it must
+;;; be a symbol. Otherwise we at the end check the result-string
+;;; against regular expressions to determine if it is possibly an
+;;; integer or a float.
(define integer-regex (make-regexp "^[+-]?[0-9]+\\.?$"))
+
(define float-regex
- (make-regexp "^[+-]?([0-9]+\\.?[0-9]*|[0-9]*\\.?[0-9]+)(e[+-]?[0-9]+)?$"))
+ (make-regexp
+ "^[+-]?([0-9]+\\.?[0-9]*|[0-9]*\\.?[0-9]+)(e[+-]?[0-9]+)?$"))
+
+;;; A dot is also allowed literally, only a single dort alone is parsed
+;;; as the 'dot' terminal for dotted lists.
-; A dot is also allowed literally, only a single dort alone is parsed as the
-; 'dot' terminal for dotted lists.
(define no-escape-punctuation (string->char-set "-+=*/address@hidden&:<>{}?."))
(define (get-symbol-or-number port)
@@ -196,55 +202,60 @@
(had-escape #f))
(let* ((c (read-char port))
(finish (lambda ()
- (let ((result (list->string (reverse result-chars))))
+ (let ((result (list->string
+ (reverse result-chars))))
(values
- (cond
- ((and (not had-escape)
- (regexp-exec integer-regex result))
- 'integer)
- ((and (not had-escape)
- (regexp-exec float-regex result))
- 'float)
- (else 'symbol))
- result))))
+ (cond
+ ((and (not had-escape)
+ (regexp-exec integer-regex result))
+ 'integer)
+ ((and (not had-escape)
+ (regexp-exec float-regex result))
+ 'float)
+ (else 'symbol))
+ result))))
(need-no-escape? (lambda (c)
(or (char-numeric? c)
(char-alphabetic? c)
- (char-set-contains? no-escape-punctuation
- c)))))
+ (char-set-contains?
+ no-escape-punctuation
+ c)))))
(cond
- ((eof-object? c) (finish))
- ((need-no-escape? c) (iterate (cons c result-chars) had-escape))
- ((char=? c #\\) (iterate (cons (read-char port) result-chars) #t))
- (else
- (unread-char c port)
- (finish))))))
-
+ ((eof-object? c) (finish))
+ ((need-no-escape? c) (iterate (cons c result-chars) had-escape))
+ ((char=? c #\\) (iterate (cons (read-char port) result-chars) #t))
+ (else
+ (unread-char c port)
+ (finish))))))
-; Parse a circular structure marker without the leading # (which was already
-; read and recognized), that is, a number as identifier and then either
-; = or #.
+;;; Parse a circular structure marker without the leading # (which was
+;;; already read and recognized), that is, a number as identifier and
+;;; then either = or #.
(define (get-circular-marker port)
(call-with-values
- (lambda ()
- (let iterate ((result 0))
- (let ((cur (read-char port)))
- (if (char-numeric? cur)
- (let ((val (- (char->integer cur) (char->integer #\0))))
- (iterate (+ (* result 10) val)))
- (values result cur)))))
+ (lambda ()
+ (let iterate ((result 0))
+ (let ((cur (read-char port)))
+ (if (char-numeric? cur)
+ (let ((val (- (char->integer cur) (char->integer #\0))))
+ (iterate (+ (* result 10) val)))
+ (values result cur)))))
(lambda (id type)
(case type
((#\#) `(circular-ref . ,id))
((#\=) `(circular-def . ,id))
- (else (lexer-error port "invalid circular marker character" type))))))
-
+ (else (lexer-error port
+ "invalid circular marker character"
+ type))))))
-; Main lexer routine, which is given a port and does look for the next token.
+;;; Main lexer routine, which is given a port and does look for the next
+;;; token.
(define (lex port)
- (let ((return (let ((file (if (file-port? port) (port-filename port) #f))
+ (let ((return (let ((file (if (file-port? port)
+ (port-filename port)
+ #f))
(line (1+ (port-line port)))
(column (1+ (port-column port))))
(lambda (token value)
@@ -253,135 +264,129 @@
(set-source-property! obj 'line line)
(set-source-property! obj 'column column)
obj))))
- ; Read afterwards so the source-properties are correct above
- ; and actually point to the very character to be read.
+ ;; Read afterwards so the source-properties are correct above
+ ;; and actually point to the very character to be read.
(c (read-char port)))
(cond
-
- ; End of input must be specially marked to the parser.
- ((eof-object? c) '*eoi*)
-
- ; Whitespace, just skip it.
- ((char-whitespace? c) (lex port))
-
- ; The dot is only the one for dotted lists if followed by
- ; whitespace. Otherwise it is considered part of a number of symbol.
- ((and (char=? c #\.)
- (char-whitespace? (peek-char port)))
- (return 'dot #f))
-
- ; Continue checking for literal character values.
- (else
- (case c
-
- ; A line comment, skip until end-of-line is found.
- ((#\;)
- (let iterate ()
- (let ((cur (read-char port)))
- (if (or (eof-object? cur) (char=? cur #\newline))
+ ;; End of input must be specially marked to the parser.
+ ((eof-object? c) (return 'eof c))
+ ;; Whitespace, just skip it.
+ ((char-whitespace? c) (lex port))
+ ;; The dot is only the one for dotted lists if followed by
+ ;; whitespace. Otherwise it is considered part of a number of
+ ;; symbol.
+ ((and (char=? c #\.)
+ (char-whitespace? (peek-char port)))
+ (return 'dot #f))
+ ;; Continue checking for literal character values.
+ (else
+ (case c
+ ;; A line comment, skip until end-of-line is found.
+ ((#\;)
+ (let iterate ()
+ (let ((cur (read-char port)))
+ (if (or (eof-object? cur) (char=? cur #\newline))
(lex port)
(iterate)))))
-
- ; A character literal.
- ((#\?)
- (return 'character (get-character port #f)))
-
- ; A literal string. This is mainly a sequence of characters just
- ; as in the character literals, the only difference is that escaped
- ; newline and space are to be completely ignored and that
meta-escapes
- ; set bit 7 rather than bit 27.
- ((#\")
- (let iterate ((result-chars '()))
- (let ((cur (read-char port)))
- (case cur
- ((#\")
- (return 'string (list->string (reverse result-chars))))
- ((#\\)
- (let ((escaped (read-char port)))
- (case escaped
- ((#\newline #\space)
- (iterate result-chars))
- (else
- (unread-char escaped port)
- (unread-char cur port)
- (iterate (cons (integer->char (get-character port #t))
- result-chars))))))
- (else (iterate (cons cur result-chars)))))))
-
- ; Circular markers (either reference or definition).
- ((#\#)
- (let ((mark (get-circular-marker port)))
- (return (car mark) (cdr mark))))
-
- ; Parentheses and other special-meaning single characters.
- ((#\() (return 'paren-open #f))
- ((#\)) (return 'paren-close #f))
- ((#\[) (return 'square-open #f))
- ((#\]) (return 'square-close #f))
- ((#\') (return 'quote #f))
- ((#\`) (return 'backquote #f))
-
- ; Unquote and unquote-splicing.
- ((#\,)
- (if (is-char? (peek-char port) #\@)
+ ;; A character literal.
+ ((#\?)
+ (return 'character (get-character port #f)))
+ ;; A literal string. This is mainly a sequence of characters
+ ;; just as in the character literals, the only difference is
+ ;; that escaped newline and space are to be completely ignored
+ ;; and that meta-escapes set bit 7 rather than bit 27.
+ ((#\")
+ (let iterate ((result-chars '()))
+ (let ((cur (read-char port)))
+ (case cur
+ ((#\")
+ (return 'string (list->string (reverse result-chars))))
+ ((#\\)
+ (let ((escaped (read-char port)))
+ (case escaped
+ ((#\newline #\space)
+ (iterate result-chars))
+ (else
+ (unread-char escaped port)
+ (unread-char cur port)
+ (iterate
+ (cons (integer->char (get-character port #t))
+ result-chars))))))
+ (else (iterate (cons cur result-chars)))))))
+ ((#\#)
+ (let ((c (read-char port)))
+ (case c
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+ (unread-char c port)
+ (let ((mark (get-circular-marker port)))
+ (return (car mark) (cdr mark))))
+ ((#\')
+ (return 'function #f)))))
+ ;; Parentheses and other special-meaning single characters.
+ ((#\() (return 'paren-open #f))
+ ((#\)) (return 'paren-close #f))
+ ((#\[) (return 'square-open #f))
+ ((#\]) (return 'square-close #f))
+ ((#\') (return 'quote #f))
+ ((#\`) (return 'backquote #f))
+ ;; Unquote and unquote-splicing.
+ ((#\,)
+ (if (is-char? (peek-char port) #\@)
(if (not (char=? (read-char port) #\@))
- (error "expected @ in unquote-splicing")
- (return 'unquote-splicing #f))
+ (error "expected @ in unquote-splicing")
+ (return 'unquote-splicing #f))
(return 'unquote #f)))
-
- ; Remaining are numbers and symbols. Process input until next
- ; whitespace is found, and see if it looks like a number
- ; (float/integer) or symbol and return accordingly.
- (else
- (unread-char c port)
- (call-with-values
- (lambda ()
- (get-symbol-or-number port))
- (lambda (type str)
- (case type
- ((symbol)
- ; str could be empty if the first character is already
- ; something not allowed in a symbol (and not escaped)!
- ; Take care about that, it is an error because that
character
- ; should have been handled elsewhere or is invalid in the
- ; input.
- (if (zero? (string-length str))
- (begin
- ; Take it out so the REPL might not get into an
- ; infinite loop with further reading attempts.
- (read-char port)
- (error "invalid character in input" c))
- (return 'symbol (string->symbol str))))
- ((integer)
- ; In elisp, something like "1." is an integer, while
- ; string->number returns an inexact real. Thus we
- ; need a conversion here, but it should always result in
- ; an integer!
- (return 'integer
- (let ((num (inexact->exact (string->number str))))
- (if (not (integer? num))
- (error "expected integer" str num))
- num)))
- ((float)
- (return 'float (let ((num (string->number str)))
- (if (exact? num)
- (error "expected inexact float" str num))
- num)))
- (else (error "wrong number/symbol type" type)))))))))))
-
-
-; Build a lexer thunk for a port. This is the exported routine which can be
-; used to create a lexer for the parser to use.
+ ;; Remaining are numbers and symbols. Process input until next
+ ;; whitespace is found, and see if it looks like a number
+ ;; (float/integer) or symbol and return accordingly.
+ (else
+ (unread-char c port)
+ (call-with-values
+ (lambda () (get-symbol-or-number port))
+ (lambda (type str)
+ (case type
+ ((symbol)
+ ;; str could be empty if the first character is already
+ ;; something not allowed in a symbol (and not escaped)!
+ ;; Take care about that, it is an error because that
+ ;; character should have been handled elsewhere or is
+ ;; invalid in the input.
+ (if (zero? (string-length str))
+ (begin
+ ;; Take it out so the REPL might not get into an
+ ;; infinite loop with further reading attempts.
+ (read-char port)
+ (error "invalid character in input" c))
+ (return 'symbol (string->symbol str))))
+ ((integer)
+ ;; In elisp, something like "1." is an integer, while
+ ;; string->number returns an inexact real. Thus we need
+ ;; a conversion here, but it should always result in an
+ ;; integer!
+ (return
+ 'integer
+ (let ((num (inexact->exact (string->number str))))
+ (if (not (integer? num))
+ (error "expected integer" str num))
+ num)))
+ ((float)
+ (return 'float (let ((num (string->number str)))
+ (if (exact? num)
+ (error "expected inexact float"
+ str
+ num))
+ num)))
+ (else (error "wrong number/symbol type" type)))))))))))
+
+;;; Build a lexer thunk for a port. This is the exported routine which
+;;; can be used to create a lexer for the parser to use.
(define (get-lexer port)
- (lambda ()
- (lex port)))
-
+ (lambda () (lex port)))
-; Build a special lexer that will only read enough for one expression and then
-; always return end-of-input.
-; If we find one of the quotation stuff, one more expression is needed in any
-; case.
+;;; Build a special lexer that will only read enough for one expression
+;;; and then always return end-of-input. If we find one of the quotation
+;;; stuff, one more expression is needed in any case.
(define (get-lexer/1 port)
(let ((lex (get-lexer port))
@@ -389,16 +394,16 @@
(paren-level 0))
(lambda ()
(if finished
- '*eoi*
- (let ((next (lex))
- (quotation #f))
- (case (car next)
- ((paren-open square-open)
- (set! paren-level (1+ paren-level)))
- ((paren-close square-close)
- (set! paren-level (1- paren-level)))
- ((quote backquote unquote unquote-splicing circular-def)
- (set! quotation #t)))
- (if (and (not quotation) (<= paren-level 0))
- (set! finished #t))
- next)))))
+ (cons 'eof ((@ (rnrs io ports) eof-object)))
+ (let ((next (lex))
+ (quotation #f))
+ (case (car next)
+ ((paren-open square-open)
+ (set! paren-level (1+ paren-level)))
+ ((paren-close square-close)
+ (set! paren-level (1- paren-level)))
+ ((quote backquote unquote unquote-splicing circular-def)
+ (set! quotation #t)))
+ (if (and (not quotation) (<= paren-level 0))
+ (set! finished #t))
+ next)))))
diff --git a/module/language/elisp/parser.scm b/module/language/elisp/parser.scm
index 4d9b0c3..df825eb 100644
--- a/module/language/elisp/parser.scm
+++ b/module/language/elisp/parser.scm
@@ -1,6 +1,6 @@
;;; Guile Emacs Lisp
-;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -22,30 +22,30 @@
#:use-module (language elisp lexer)
#:export (read-elisp))
-; The parser (reader) for elisp expressions.
-; Is is hand-written (just as the lexer is) instead of using some parser
-; generator because this allows easier transfer of source properties from the
-; lexer ((text parse-lalr) seems not to allow access to the original lexer
-; token-pair) and is easy enough anyways.
-
+;;; The parser (reader) for elisp expressions.
+;;;
+;;; It is hand-written (just as the lexer is) instead of using some
+;;; parser generator because this allows easier transfer of source
+;;; properties from the lexer ((text parse-lalr) seems not to allow
+;;; access to the original lexer token-pair) and is easy enough anyways.
-; Report a parse error. The first argument is some current lexer token
-; where source information is available should it be useful.
+;;; Report a parse error. The first argument is some current lexer
+;;; token where source information is available should it be useful.
(define (parse-error token msg . args)
(apply error msg args))
-
-; For parsing circular structures, we keep track of definitions in a
-; hash-map that maps the id's to their values.
-; When defining a new id, though, we immediatly fill the slot with a promise
-; before parsing and setting the real value, because it must already be
-; available at that time in case of a circular reference. The promise refers
-; to a local variable that will be set when the real value is available through
-; a closure. After parsing the expression is completed, we work through it
-; again and force all promises we find.
-; The definitions themselves are stored in a fluid and their scope is one
-; call to read-elisp (but not only the currently parsed expression!).
+;;; For parsing circular structures, we keep track of definitions in a
+;;; hash-map that maps the id's to their values. When defining a new
+;;; id, though, we immediatly fill the slot with a promise before
+;;; parsing and setting the real value, because it must already be
+;;; available at that time in case of a circular reference. The promise
+;;; refers to a local variable that will be set when the real value is
+;;; available through a closure. After parsing the expression is
+;;; completed, we work through it again and force all promises we find.
+;;; The definitions themselves are stored in a fluid and their scope is
+;;; one call to read-elisp (but not only the currently parsed
+;;; expression!).
(define circular-definitions (make-fluid))
@@ -54,19 +54,20 @@
(define (circular-ref token)
(if (not (eq? (car token) 'circular-ref))
- (error "invalid token for circular-ref" token))
+ (error "invalid token for circular-ref" token))
(let* ((id (cdr token))
(value (hashq-ref (fluid-ref circular-definitions) id)))
(if value
- value
- (parse-error token "undefined circular reference" id))))
+ value
+ (parse-error token "undefined circular reference" id))))
+
+;;; Returned is a closure that, when invoked, will set the final value.
+;;; This means both the variable the promise will return and the
+;;; hash-table slot so we don't generate promises any longer.
-; Returned is a closure that, when invoked, will set the final value.
-; This means both the variable the promise will return and the hash-table
-; slot so we don't generate promises any longer.
(define (circular-define! token)
(if (not (eq? (car token) 'circular-def))
- (error "invalid token for circular-define!" token))
+ (error "invalid token for circular-define!" token))
(let ((value #f)
(table (fluid-ref circular-definitions))
(id (cdr token)))
@@ -75,112 +76,118 @@
(set! value real-value)
(hashq-set! table id real-value))))
-; Work through a parsed data structure and force the promises there.
-; After a promise is forced, the resulting value must not be recursed on;
-; this may lead to infinite recursion with a circular structure, and
-; additionally this value was already processed when it was defined.
-; All deep data structures that can be parsed must be handled here!
+;;; Work through a parsed data structure and force the promises there.
+;;; After a promise is forced, the resulting value must not be recursed
+;;; on; this may lead to infinite recursion with a circular structure,
+;;; and additionally this value was already processed when it was
+;;; defined. All deep data structures that can be parsed must be
+;;; handled here!
+
(define (force-promises! data)
(cond
- ((pair? data)
- (begin
- (if (promise? (car data))
- (set-car! data (force (car data)))
- (force-promises! (car data)))
- (if (promise? (cdr data))
- (set-cdr! data (force (cdr data)))
- (force-promises! (cdr data)))))
- ((vector? data)
- (let ((len (vector-length data)))
- (let iterate ((i 0))
- (if (< i len)
- (let ((el (vector-ref data i)))
- (if (promise? el)
- (vector-set! data i (force el))
- (force-promises! el))
- (iterate (1+ i)))))))
- ; Else nothing needs to be done.
- ))
-
-
-; We need peek-functionality for the next lexer token, this is done with some
-; single token look-ahead storage. This is handled by a closure which allows
-; getting or peeking the next token.
-; When one expression is fully parsed, we don't want a look-ahead stored here
-; because it would miss from future parsing. This is verified by the finish
-; action.
+ ((pair? data)
+ (begin
+ (if (promise? (car data))
+ (set-car! data (force (car data)))
+ (force-promises! (car data)))
+ (if (promise? (cdr data))
+ (set-cdr! data (force (cdr data)))
+ (force-promises! (cdr data)))))
+ ((vector? data)
+ (let ((len (vector-length data)))
+ (let iterate ((i 0))
+ (if (< i len)
+ (let ((el (vector-ref data i)))
+ (if (promise? el)
+ (vector-set! data i (force el))
+ (force-promises! el))
+ (iterate (1+ i)))))))
+ ;; Else nothing needs to be done.
+ ))
+
+;;; We need peek-functionality for the next lexer token, this is done
+;;; with some single token look-ahead storage. This is handled by a
+;;; closure which allows getting or peeking the next token. When one
+;;; expression is fully parsed, we don't want a look-ahead stored here
+;;; because it would miss from future parsing. This is verified by the
+;;; finish action.
(define (make-lexer-buffer lex)
(let ((look-ahead #f))
(lambda (action)
(if (eq? action 'finish)
- (if look-ahead
- (error "lexer-buffer is not empty when finished")
- #f)
- (begin
- (if (not look-ahead)
- (set! look-ahead (lex)))
- (case action
- ((peek) look-ahead)
- ((get)
- (let ((result look-ahead))
- (set! look-ahead #f)
- result))
- (else (error "invalid lexer-buffer action" action))))))))
-
-
-; Get the contents of a list, where the opening parentheses has already been
-; found. The same code is used for vectors and lists, where lists allow the
-; dotted tail syntax and vectors not; additionally, the closing parenthesis
-; must of course match.
-; The implementation here is not tail-recursive, but I think it is clearer
-; and simpler this way.
+ (if look-ahead
+ (error "lexer-buffer is not empty when finished")
+ #f)
+ (begin
+ (if (not look-ahead)
+ (set! look-ahead (lex)))
+ (case action
+ ((peek) look-ahead)
+ ((get)
+ (let ((result look-ahead))
+ (set! look-ahead #f)
+ result))
+ (else (error "invalid lexer-buffer action" action))))))))
+
+;;; Get the contents of a list, where the opening parentheses has
+;;; already been found. The same code is used for vectors and lists,
+;;; where lists allow the dotted tail syntax and vectors not;
+;;; additionally, the closing parenthesis must of course match. The
+;;; implementation here is not tail-recursive, but I think it is clearer
+;;; and simpler this way.
(define (get-list lex allow-dot close-square)
(let* ((next (lex 'peek))
(type (car next)))
(cond
- ((eq? type (if close-square 'square-close 'paren-close))
- (begin
- (if (not (eq? (car (lex 'get)) type))
- (error "got different token than peeked"))
- '()))
- ((and allow-dot (eq? type 'dot))
- (begin
- (if (not (eq? (car (lex 'get)) type))
- (error "got different token than peeked"))
- (let ((tail (get-list lex #f close-square)))
- (if (not (= (length tail) 1))
- (parse-error next "expected exactly one element after dot"))
- (car tail))))
- (else
- ; Do both parses in exactly this sequence!
- (let* ((head (get-expression lex))
- (tail (get-list lex allow-dot close-square)))
- (cons head tail))))))
-
-
-
-; Parse a single expression from a lexer-buffer. This is the main routine in
-; our recursive-descent parser.
+ ((eq? type (if close-square 'square-close 'paren-close))
+ (begin
+ (if (not (eq? (car (lex 'get)) type))
+ (error "got different token than peeked"))
+ '()))
+ ((and allow-dot (eq? type 'dot))
+ (begin
+ (if (not (eq? (car (lex 'get)) type))
+ (error "got different token than peeked"))
+ (let ((tail (get-list lex #f close-square)))
+ (if (not (= (length tail) 1))
+ (parse-error next
+ "expected exactly one element after dot"))
+ (car tail))))
+ (else
+ ;; Do both parses in exactly this sequence!
+ (let* ((head (get-expression lex))
+ (tail (get-list lex allow-dot close-square)))
+ (cons head tail))))))
+
+;;; Parse a single expression from a lexer-buffer. This is the main
+;;; routine in our recursive-descent parser.
(define quotation-symbols '((quote . quote)
- (backquote . \`)
- (unquote . \,)
- (unquote-splicing . \,@)))
+ (backquote . #{`}#)
+ (unquote . #{,}#)
+ (unquote-splicing . #{,@}#)))
(define (get-expression lex)
(let* ((token (lex 'get))
(type (car token))
(return (lambda (result)
(if (pair? result)
- (set-source-properties! result (source-properties token)))
+ (set-source-properties!
+ result
+ (source-properties token)))
result)))
(case type
+ ((eof)
+ (parse-error token "end of file during parsing"))
((integer float symbol character string)
(return (cdr token)))
+ ((function)
+ (return `(function ,(get-expression lex))))
((quote backquote unquote unquote-splicing)
- (return (list (assq-ref quotation-symbols type) (get-expression lex))))
+ (return (list (assq-ref quotation-symbols type)
+ (get-expression lex))))
((paren-open)
(return (get-list lex #t #f)))
((square-open)
@@ -188,24 +195,26 @@
((circular-ref)
(circular-ref token))
((circular-def)
- ; The order of definitions is important!
+ ;; The order of definitions is important!
(let* ((setter (circular-define! token))
(expr (get-expression lex)))
(setter expr)
(force-promises! expr)
expr))
(else
- (parse-error token "expected expression, got" token)))))
-
+ (parse-error token "expected expression, got" token)))))
-; Define the reader function based on this; build a lexer, a lexer-buffer,
-; and then parse a single expression to return.
-; We also define a circular-definitions data structure to use.
+;;; Define the reader function based on this; build a lexer, a
+;;; lexer-buffer, and then parse a single expression to return. We also
+;;; define a circular-definitions data structure to use.
(define (read-elisp port)
(with-fluids ((circular-definitions (make-circular-definitions)))
(let* ((lexer (get-lexer port))
(lexbuf (make-lexer-buffer lexer))
- (result (get-expression lexbuf)))
- (lexbuf 'finish)
- result)))
+ (next (lexbuf 'peek)))
+ (if (eq? (car next) 'eof)
+ (cdr next)
+ (let ((result (get-expression lexbuf)))
+ (lexbuf 'finish)
+ result)))))
diff --git a/module/language/elisp/runtime.scm
b/module/language/elisp/runtime.scm
index 0d783b6..47306e6 100644
--- a/module/language/elisp/runtime.scm
+++ b/module/language/elisp/runtime.scm
@@ -19,107 +19,134 @@
;;; Code:
(define-module (language elisp runtime)
- #:export (void
- nil-value t-value
- value-slot-module function-slot-module
-
+ #:export (nil-value
+ t-value
+ value-slot-module
+ function-slot-module
elisp-bool
-
- ensure-fluid! reference-variable reference-variable-with-check
+ ensure-fluid!
+ reference-variable
set-variable!
+ runtime-error
+ macro-error)
+ #:export-syntax (built-in-func built-in-macro defspecial prim))
- runtime-error macro-error)
- #:export-syntax (built-in-func built-in-macro prim))
-
-; This module provides runtime support for the Elisp front-end.
-
-
-; The reserved value to mean (when eq?) void.
-
-(define void (list 42))
+;;; This module provides runtime support for the Elisp front-end.
-
-; Values for t and nil. (FIXME remove this abstraction)
+;;; Values for t and nil. (FIXME remove this abstraction)
(define nil-value #nil)
-(define t-value #t)
+(define t-value #t)
-; Modules for the binding slots.
-; Note: Naming those value-slot and/or function-slot clashes with the
-; submodules of these names!
+;;; Modules for the binding slots.
+;;; Note: Naming those value-slot and/or function-slot clashes with the
+;;; submodules of these names!
(define value-slot-module '(language elisp runtime value-slot))
-(define function-slot-module '(language elisp runtime function-slot))
+(define function-slot-module '(language elisp runtime function-slot))
-; Report an error during macro compilation, that means some special compilation
-; (syntax) error; or report a simple runtime-error from a built-in function.
+;;; Report an error during macro compilation, that means some special
+;;; compilation (syntax) error; or report a simple runtime-error from a
+;;; built-in function.
(define (macro-error msg . args)
(apply error msg args))
(define runtime-error macro-error)
-
-; Convert a scheme boolean to Elisp.
+;;; Convert a scheme boolean to Elisp.
(define (elisp-bool b)
(if b
- t-value
- nil-value))
+ t-value
+ nil-value))
-
-; Routines for access to elisp dynamically bound symbols.
-; This is used for runtime access using functions like symbol-value or set,
-; where the symbol accessed might not be known at compile-time.
-; These always access the dynamic binding and can not be used for the lexical!
+;;; Routines for access to elisp dynamically bound symbols. This is
+;;; used for runtime access using functions like symbol-value or set,
+;;; where the symbol accessed might not be known at compile-time. These
+;;; always access the dynamic binding and can not be used for the
+;;; lexical!
(define (ensure-fluid! module sym)
(let ((intf (resolve-interface module))
(resolved (resolve-module module)))
(if (not (module-defined? intf sym))
- (let ((fluid (make-fluid)))
- (fluid-set! fluid void)
- (module-define! resolved sym fluid)
- (module-export! resolved `(,sym))))))
+ (let ((fluid (make-undefined-fluid)))
+ (module-define! resolved sym fluid)
+ (module-export! resolved `(,sym))))))
(define (reference-variable module sym)
- (ensure-fluid! module sym)
(let ((resolved (resolve-module module)))
- (fluid-ref (module-ref resolved sym))))
-
-(define (reference-variable-with-check module sym)
- (let ((value (reference-variable module sym)))
- (if (eq? value void)
- (runtime-error "variable is void:" sym)
- value)))
+ (cond
+ ((equal? module function-slot-module)
+ (module-ref resolved sym))
+ (else
+ (ensure-fluid! module sym)
+ (fluid-ref (module-ref resolved sym))))))
(define (set-variable! module sym value)
- (ensure-fluid! module sym)
- (let ((resolved (resolve-module module)))
- (fluid-set! (module-ref resolved sym) value)
- value))
-
-
-; Define a predefined function or predefined macro for use in the function-slot
-; and macro-slot modules, respectively.
+ (let ((intf (resolve-interface module))
+ (resolved (resolve-module module)))
+ (cond
+ ((equal? module function-slot-module)
+ (cond
+ ((module-defined? intf sym)
+ (module-set! resolved sym value))
+ (else
+ (module-define! resolved sym value)
+ (module-export! resolved `(,sym)))))
+ (else
+ (ensure-fluid! module sym)
+ (fluid-set! (module-ref resolved sym) value))))
+ value)
+
+;;; Define a predefined function or predefined macro for use in the
+;;; function-slot and macro-slot modules, respectively.
(define-syntax built-in-func
(syntax-rules ()
((_ name value)
(begin
- (define-public name (make-fluid))
- (fluid-set! name value)))))
+ (define-public name value)))))
+
+(define (make-id template-id . data)
+ (let ((append-symbols
+ (lambda (symbols)
+ (string->symbol
+ (apply string-append (map symbol->string symbols))))))
+ (datum->syntax template-id
+ (append-symbols
+ (map (lambda (datum)
+ ((if (identifier? datum)
+ syntax->datum
+ identity)
+ datum))
+ data)))))
(define-syntax built-in-macro
- (syntax-rules ()
- ((_ name value)
- (define-public name value))))
-
-
-; Call a guile-primitive that may be rebound for elisp and thus needs absolute
-; addressing.
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name value)
+ (with-syntax ((scheme-name (make-id #'name 'macro- #'name)))
+ #'(begin
+ (define-public scheme-name (make-fluid))
+ (fluid-set! scheme-name (cons 'macro value))))))))
+
+(define-syntax defspecial
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name args body ...)
+ (with-syntax ((scheme-name (make-id #'name 'compile- #'name)))
+ #'(begin
+ (define scheme-name (make-fluid))
+ (fluid-set! scheme-name
+ (cons 'special-operator
+ (lambda args body ...)))))))))
+
+;;; Call a guile-primitive that may be rebound for elisp and thus needs
+;;; absolute addressing.
(define-syntax prim
(syntax-rules ()
diff --git a/module/language/elisp/runtime/function-slot.scm
b/module/language/elisp/runtime/function-slot.scm
index 9d88b22..896e3ce 100644
--- a/module/language/elisp/runtime/function-slot.scm
+++ b/module/language/elisp/runtime/function-slot.scm
@@ -1,6 +1,6 @@
;;; Guile Emacs Lisp
-;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -16,298 +16,143 @@
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-;;; Code:
-
(define-module (language elisp runtime function-slot)
- #:use-module (language elisp runtime)
- #:use-module (system base compile))
-
-; This module contains the function-slots of elisp symbols. Elisp built-in
-; functions are implemented as predefined function bindings here.
-
-
-; Equivalence and equalness predicates.
-
-(built-in-func eq (lambda (a b)
- (elisp-bool (eq? a b))))
-
-(built-in-func equal (lambda (a b)
- (elisp-bool (equal? a b))))
-
-
-; Number predicates.
-
-(built-in-func floatp (lambda (num)
- (elisp-bool (and (real? num)
- (or (inexact? num)
- (prim not (integer? num)))))))
-
-(built-in-func integerp (lambda (num)
- (elisp-bool (and (exact? num)
- (integer? num)))))
-
-(built-in-func numberp (lambda (num)
- (elisp-bool (real? num))))
-
-(built-in-func wholenump (lambda (num)
- (elisp-bool (and (exact? num)
- (integer? num)
- (prim >= num 0)))))
-
-(built-in-func zerop (lambda (num)
- (elisp-bool (prim = num 0))))
-
-
-; Number comparisons.
-
-(built-in-func = (lambda (num1 num2)
- (elisp-bool (prim = num1 num2))))
-(built-in-func /= (lambda (num1 num2)
- (elisp-bool (prim not (prim = num1 num2)))))
-
-(built-in-func < (lambda (num1 num2)
- (elisp-bool (prim < num1 num2))))
-(built-in-func <= (lambda (num1 num2)
- (elisp-bool (prim <= num1 num2))))
-(built-in-func > (lambda (num1 num2)
- (elisp-bool (prim > num1 num2))))
-(built-in-func >= (lambda (num1 num2)
- (elisp-bool (prim >= num1 num2))))
-
-(built-in-func max (lambda (. nums)
- (prim apply (@ (guile) max) nums)))
-(built-in-func min (lambda (. nums)
- (prim apply (@ (guile) min) nums)))
-
-(built-in-func abs (@ (guile) abs))
-
-
-; Number conversion.
-
-(built-in-func float (lambda (num)
- (if (exact? num)
- (exact->inexact num)
- num)))
-
-; TODO: truncate, floor, ceiling, round.
-
-
-; Arithmetic functions.
-
-(built-in-func 1+ (@ (guile) 1+))
-(built-in-func 1- (@ (guile) 1-))
-(built-in-func + (@ (guile) +))
-(built-in-func - (@ (guile) -))
-(built-in-func * (@ (guile) *))
-(built-in-func % (@ (guile) modulo))
-
-; TODO: / with correct integer/real behaviour, mod (for floating-piont values).
-
-
-; Floating-point rounding operations.
-
-(built-in-func ffloor (@ (guile) floor))
-(built-in-func fceiling (@ (guile) ceiling))
-(built-in-func ftruncate (@ (guile) truncate))
-(built-in-func fround (@ (guile) round))
-
-
-; List predicates.
-
-(built-in-func consp
- (lambda (el)
- (elisp-bool (pair? el))))
-(built-in-func atomp
- (lambda (el)
- (elisp-bool (prim not (pair? el)))))
-
-(built-in-func listp
- (lambda (el)
- (elisp-bool (or (pair? el) (null? el)))))
-(built-in-func nlistp
- (lambda (el)
- (elisp-bool (and (prim not (pair? el))
- (prim not (null? el))))))
-
-(built-in-func null
- (lambda (el)
- (elisp-bool (null? el))))
-
-
-; Accessing list elements.
-
-(built-in-func car
- (lambda (el)
- (if (null? el)
- nil-value
- (prim car el))))
-(built-in-func cdr
- (lambda (el)
- (if (null? el)
- nil-value
- (prim cdr el))))
-
-(built-in-func car-safe
- (lambda (el)
- (if (pair? el)
- (prim car el)
- nil-value)))
-(built-in-func cdr-safe
- (lambda (el)
- (if (pair? el)
- (prim cdr el)
- nil-value)))
-
-(built-in-func nth
- (lambda (n lst)
- (if (negative? n)
- (prim car lst)
- (let iterate ((i n)
- (tail lst))
- (cond
- ((null? tail) nil-value)
- ((zero? i) (prim car tail))
- (else (iterate (prim 1- i) (prim cdr tail))))))))
-(built-in-func nthcdr
- (lambda (n lst)
- (if (negative? n)
- lst
- (let iterate ((i n)
- (tail lst))
- (cond
- ((null? tail) nil-value)
- ((zero? i) tail)
- (else (iterate (prim 1- i) (prim cdr tail))))))))
-
-(built-in-func length (@ (guile) length))
-
-
-; Building lists.
-
-(built-in-func cons (@ (guile) cons))
-(built-in-func list (@ (guile) list))
-(built-in-func make-list
- (lambda (len obj)
- (prim make-list len obj)))
-
-(built-in-func append (@ (guile) append))
-(built-in-func reverse (@ (guile) reverse))
-(built-in-func copy-tree (@ (guile) copy-tree))
-
-(built-in-func number-sequence
- (lambda (from . rest)
- (if (prim > (prim length rest) 2)
- (runtime-error "too many arguments for number-sequence"
- (prim cdddr rest))
- (if (null? rest)
- `(,from)
- (let ((to (prim car rest))
- (sep (if (or (null? (prim cdr rest))
- (eq? nil-value (prim cadr rest)))
- 1
- (prim cadr rest))))
- (cond
- ((or (eq? nil-value to) (prim = to from)) `(,from))
- ((and (zero? sep) (prim not (prim = from to)))
- (runtime-error "infinite list in number-sequence"))
- ((prim < (prim * to sep) (prim * from sep)) '())
- (else
- (let iterate ((i (prim +
- from
- (prim * sep
- (prim quotient
- (prim abs (prim - to from))
- (prim abs sep)))))
- (result '()))
- (if (prim = i from)
- (prim cons i result)
- (iterate (prim - i sep) (prim cons i result)))))))))))
-
-
-; Changing lists.
-
-(built-in-func setcar
- (lambda (cell val)
- (prim set-car! cell val)
- val))
-
-(built-in-func setcdr
- (lambda (cell val)
- (prim set-cdr! cell val)
- val))
-
-
-; Accessing symbol bindings for symbols known only at runtime.
-
-(built-in-func symbol-value
- (lambda (sym)
- (reference-variable-with-check value-slot-module sym)))
-(built-in-func symbol-function
- (lambda (sym)
- (reference-variable-with-check function-slot-module sym)))
-
-(built-in-func set
- (lambda (sym value)
- (set-variable! value-slot-module sym value)))
-(built-in-func fset
- (lambda (sym value)
- (set-variable! function-slot-module sym value)))
-
-(built-in-func makunbound
- (lambda (sym)
- (set-variable! value-slot-module sym void)
- sym))
-(built-in-func fmakunbound
- (lambda (sym)
- (set-variable! function-slot-module sym void)
- sym))
-
-(built-in-func boundp
- (lambda (sym)
- (elisp-bool (prim not
- (eq? void (reference-variable value-slot-module sym))))))
-(built-in-func fboundp
- (lambda (sym)
- (elisp-bool (prim not
- (eq? void (reference-variable function-slot-module sym))))))
-
-
-; Function calls. These must take care of special cases, like using symbols
-; or raw lambda-lists as functions!
-
-(built-in-func apply
- (lambda (func . args)
- (let ((real-func (cond
- ((symbol? func)
- (reference-variable-with-check function-slot-module
- func))
- ((list? func)
- (if (and (prim not (null? func))
- (eq? (prim car func) 'lambda))
- (compile func #:from 'elisp #:to 'value)
- (runtime-error "list is not a function" func)))
- (else func))))
- (prim apply (@ (guile) apply) real-func args))))
-
-(built-in-func funcall
- (let ((myapply (fluid-ref apply)))
- (lambda (func . args)
- (myapply func args))))
-
-
-; Throw can be implemented as built-in function.
-
-(built-in-func throw
- (lambda (tag value)
- (prim throw 'elisp-exception tag value)))
-
-
-; Miscellaneous.
-
-(built-in-func not
- (lambda (x)
- (if x nil-value t-value)))
-
-(built-in-func eval
- (lambda (form)
- (compile form #:from 'elisp #:to 'value)))
+ #:use-module (language elisp runtime subrs)
+ #:use-module ((language elisp runtime macros)
+ #:select
+ ((macro-lambda . lambda)
+ (macro-prog1 . prog1)
+ (macro-prog2 . prog2)
+ (macro-when . when)
+ (macro-unless . unless)
+ (macro-cond . cond)
+ (macro-and . and)
+ (macro-or . or)
+ (macro-dotimes . dotimes)
+ (macro-dolist . dolist)
+ (macro-catch . catch)
+ (macro-unwind-protect . unwind-protect)
+ (macro-pop . pop)
+ (macro-push . push)))
+ #:use-module ((language elisp compile-tree-il)
+ #:select
+ ((compile-progn . progn)
+ (compile-if . if)
+ (compile-defconst . defconst)
+ (compile-defvar . defvar)
+ (compile-setq . setq)
+ (compile-let . let)
+ (compile-lexical-let . lexical-let)
+ (compile-flet . flet)
+ (compile-let* . let*)
+ (compile-lexical-let* . lexical-let*)
+ (compile-flet* . flet*)
+ (compile-with-always-lexical . with-always-lexical)
+ (compile-guile-ref . guile-ref)
+ (compile-guile-primitive . guile-primitive)
+ (compile-while . while)
+ (compile-function . function)
+ (compile-defun . defun)
+ (compile-defmacro . defmacro)
+ (#{compile-`}# . #{`}#)
+ (compile-quote . quote)))
+ #:duplicates (last)
+ ;; special operators
+ #:re-export (progn
+ if
+ defconst
+ defvar
+ setq
+ let
+ lexical-let
+ flet
+ let*
+ lexical-let*
+ flet*
+ with-always-lexical
+ guile-ref
+ guile-primitive
+ while
+ function
+ defun
+ defmacro
+ #{`}#
+ quote)
+ ;; macros
+ #:re-export (lambda
+ prog1
+ prog2
+ when
+ unless
+ cond
+ and
+ or
+ dotimes
+ dolist
+ catch
+ unwind-protect
+ pop
+ push)
+ ;; functions
+ #:re-export (eq
+ equal
+ floatp
+ integerp
+ numberp
+ wholenump
+ zerop
+ =
+ /=
+ <
+ <=
+ >
+ >=
+ max
+ min
+ abs
+ float
+ 1+
+ 1-
+ +
+ -
+ *
+ %
+ ffloor
+ fceiling
+ ftruncate
+ fround
+ consp
+ atomp
+ listp
+ nlistp
+ null
+ car
+ cdr
+ car-safe
+ cdr-safe
+ nth
+ nthcdr
+ length
+ cons
+ list
+ make-list
+ append
+ reverse
+ copy-tree
+ number-sequence
+ setcar
+ setcdr
+ symbol-value
+ symbol-function
+ set
+ fset
+ makunbound
+ fmakunbound
+ boundp
+ fboundp
+ apply
+ funcall
+ throw
+ not
+ eval
+ load))
diff --git a/module/language/elisp/runtime/macro-slot.scm
b/module/language/elisp/runtime/macro-slot.scm
deleted file mode 100644
index e28fa31..0000000
--- a/module/language/elisp/runtime/macro-slot.scm
+++ /dev/null
@@ -1,209 +0,0 @@
-;;; Guile Emacs Lisp
-
-;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
-;;;
-;;; This library is free software; you can redistribute it and/or
-;;; modify it under the terms of the GNU Lesser General Public
-;;; License as published by the Free Software Foundation; either
-;;; version 3 of the License, or (at your option) any later version.
-;;;
-;;; This library 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
-;;; Lesser General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with this library; if not, write to the Free Software
-;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-(define-module (language elisp runtime macro-slot)
- #:use-module (language elisp runtime))
-
-; This module contains the macro definitions of elisp symbols. In contrast to
-; the other runtime modules, those are used directly during compilation, of
-; course, so not really in runtime. But I think it fits well to the others
-; here.
-
-
-; The prog1 and prog2 constructs can easily be defined as macros using progn
-; and some lexical-let's to save the intermediate value to return at the end.
-
-(built-in-macro prog1
- (lambda (form1 . rest)
- (let ((temp (gensym)))
- `(without-void-checks (,temp)
- (lexical-let ((,temp ,form1))
- ,@rest
- ,temp)))))
-
-(built-in-macro prog2
- (lambda (form1 form2 . rest)
- `(progn ,form1 (prog1 ,form2 ,@rest))))
-
-
-; Define the conditionals when and unless as macros.
-
-(built-in-macro when
- (lambda (condition . thens)
- `(if ,condition (progn ,@thens) nil)))
-
-(built-in-macro unless
- (lambda (condition . elses)
- `(if ,condition nil (progn ,@elses))))
-
-
-; Impement the cond form as nested if's. A special case is a (condition)
-; subform, in which case we need to return the condition itself if it is true
-; and thus save it in a local variable before testing it.
-
-(built-in-macro cond
- (lambda (. clauses)
- (let iterate ((tail clauses))
- (if (null? tail)
- 'nil
- (let ((cur (car tail))
- (rest (iterate (cdr tail))))
- (prim cond
- ((prim or (not (list? cur)) (null? cur))
- (macro-error "invalid clause in cond" cur))
- ((null? (cdr cur))
- (let ((var (gensym)))
- `(without-void-checks (,var)
- (lexical-let ((,var ,(car cur)))
- (if ,var
- ,var
- ,rest)))))
- (else
- `(if ,(car cur)
- (progn ,@(cdr cur))
- ,rest))))))))
-
-
-; The and and or forms can also be easily defined with macros.
-
-(built-in-macro and
- (case-lambda
- (() 't)
- ((x) x)
- ((x . args)
- (let iterate ((x x) (tail args))
- (if (null? tail)
- x
- `(if ,x
- ,(iterate (car tail) (cdr tail))
- nil))))))
-
-(built-in-macro or
- (case-lambda
- (() 'nil)
- ((x) x)
- ((x . args)
- (let iterate ((x x) (tail args))
- (if (null? tail)
- x
- (let ((var (gensym)))
- `(without-void-checks
- (,var)
- (lexical-let ((,var ,x))
- (if ,var
- ,var
- ,(iterate (car tail) (cdr tail)))))))))))
-
-
-; Define the dotimes and dolist iteration macros.
-
-(built-in-macro dotimes
- (lambda (args . body)
- (if (prim or (not (list? args))
- (< (length args) 2)
- (> (length args) 3))
- (macro-error "invalid dotimes arguments" args)
- (let ((var (car args))
- (count (cadr args)))
- (if (not (symbol? var))
- (macro-error "expected symbol as dotimes variable"))
- `(let ((,var 0))
- (while ((guile-primitive <) ,var ,count)
- ,@body
- (setq ,var ((guile-primitive 1+) ,var)))
- ,@(if (= (length args) 3)
- (list (caddr args))
- '()))))))
-
-(built-in-macro dolist
- (lambda (args . body)
- (if (prim or (not (list? args))
- (< (length args) 2)
- (> (length args) 3))
- (macro-error "invalid dolist arguments" args)
- (let ((var (car args))
- (iter-list (cadr args))
- (tailvar (gensym)))
- (if (not (symbol? var))
- (macro-error "expected symbol as dolist variable")
- `(let (,var)
- (without-void-checks (,tailvar)
- (lexical-let ((,tailvar ,iter-list))
- (while ((guile-primitive not)
- ((guile-primitive null?) ,tailvar))
- (setq ,var ((guile-primitive car) ,tailvar))
- ,@body
- (setq ,tailvar ((guile-primitive cdr) ,tailvar)))
- ,@(if (= (length args) 3)
- (list (caddr args))
- '())))))))))
-
-
-; Exception handling. unwind-protect and catch are implemented as macros
(throw
-; is a built-in function).
-
-; catch and throw can mainly be implemented directly using Guile's
-; primitives for exceptions, the only difficulty is that the keys used
-; within Guile must be symbols, while elisp allows any value and checks
-; for matches using eq (eq?). We handle this by using always #t as key
-; for the Guile primitives and check for matches inside the handler; if
-; the elisp keys are not eq?, we rethrow the exception.
-(built-in-macro catch
- (lambda (tag . body)
- (if (null? body)
- (macro-error "catch with empty body"))
- (let ((tagsym (gensym)))
- `(lexical-let ((,tagsym ,tag))
- ((guile-primitive catch)
- #t
- (lambda () ,@body)
- ,(let* ((dummy-key (gensym))
- (elisp-key (gensym))
- (value (gensym))
- (arglist `(,dummy-key ,elisp-key ,value)))
- `(with-always-lexical ,arglist
- (lambda ,arglist
- (if (eq ,elisp-key ,tagsym)
- ,value
- ((guile-primitive throw) ,dummy-key ,elisp-key
- ,value))))))))))
-
-; unwind-protect is just some weaker construct as dynamic-wind, so
-; straight-forward to implement.
-(built-in-macro unwind-protect
- (lambda (body . clean-ups)
- (if (null? clean-ups)
- (macro-error "unwind-protect without cleanup code"))
- `((guile-primitive dynamic-wind)
- (lambda () nil)
- (lambda () ,body)
- (lambda () ,@clean-ups))))
-
-
-; Pop off the first element from a list or push one to it.
-
-(built-in-macro pop
- (lambda (list-name)
- `(prog1 (car ,list-name)
- (setq ,list-name (cdr ,list-name)))))
-
-(built-in-macro push
- (lambda (new-el list-name)
- `(setq ,list-name (cons ,new-el ,list-name))))
diff --git a/module/language/elisp/runtime/macros.scm
b/module/language/elisp/runtime/macros.scm
new file mode 100644
index 0000000..a62f721
--- /dev/null
+++ b/module/language/elisp/runtime/macros.scm
@@ -0,0 +1,208 @@
+;;; Guile Emacs Lisp
+
+;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library 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
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Code:
+
+(define-module (language elisp runtime macros)
+ #:use-module (language elisp runtime))
+
+;;; This module contains the macro definitions of elisp symbols. In
+;;; contrast to the other runtime modules, those are used directly
+;;; during compilation, of course, so not really in runtime. But I
+;;; think it fits well to the others here.
+
+(built-in-macro lambda
+ (lambda cdr
+ `(function (lambda ,@cdr))))
+
+;;; The prog1 and prog2 constructs can easily be defined as macros using
+;;; progn and some lexical-let's to save the intermediate value to
+;;; return at the end.
+
+(built-in-macro prog1
+ (lambda (form1 . rest)
+ (let ((temp (gensym)))
+ `(lexical-let ((,temp ,form1))
+ ,@rest
+ ,temp))))
+
+(built-in-macro prog2
+ (lambda (form1 form2 . rest)
+ `(progn ,form1 (prog1 ,form2 ,@rest))))
+
+;;; Define the conditionals when and unless as macros.
+
+(built-in-macro when
+ (lambda (condition . thens)
+ `(if ,condition (progn ,@thens) nil)))
+
+(built-in-macro unless
+ (lambda (condition . elses)
+ `(if ,condition nil (progn ,@elses))))
+
+;;; Impement the cond form as nested if's. A special case is a
+;;; (condition) subform, in which case we need to return the condition
+;;; itself if it is true and thus save it in a local variable before
+;;; testing it.
+
+(built-in-macro cond
+ (lambda (. clauses)
+ (let iterate ((tail clauses))
+ (if (null? tail)
+ 'nil
+ (let ((cur (car tail))
+ (rest (iterate (cdr tail))))
+ (prim cond
+ ((prim or (not (list? cur)) (null? cur))
+ (macro-error "invalid clause in cond" cur))
+ ((null? (cdr cur))
+ (let ((var (gensym)))
+ `(lexical-let ((,var ,(car cur)))
+ (if ,var
+ ,var
+ ,rest))))
+ (else
+ `(if ,(car cur)
+ (progn ,@(cdr cur))
+ ,rest))))))))
+
+;;; The and and or forms can also be easily defined with macros.
+
+(built-in-macro and
+ (case-lambda
+ (() 't)
+ ((x) x)
+ ((x . args)
+ (let iterate ((x x) (tail args))
+ (if (null? tail)
+ x
+ `(if ,x
+ ,(iterate (car tail) (cdr tail))
+ nil))))))
+
+(built-in-macro or
+ (case-lambda
+ (() 'nil)
+ ((x) x)
+ ((x . args)
+ (let iterate ((x x) (tail args))
+ (if (null? tail)
+ x
+ (let ((var (gensym)))
+ `(lexical-let ((,var ,x))
+ (if ,var
+ ,var
+ ,(iterate (car tail) (cdr tail))))))))))
+
+;;; Define the dotimes and dolist iteration macros.
+
+(built-in-macro dotimes
+ (lambda (args . body)
+ (if (prim or
+ (not (list? args))
+ (< (length args) 2)
+ (> (length args) 3))
+ (macro-error "invalid dotimes arguments" args)
+ (let ((var (car args))
+ (count (cadr args)))
+ (if (not (symbol? var))
+ (macro-error "expected symbol as dotimes variable"))
+ `(let ((,var 0))
+ (while ((guile-primitive <) ,var ,count)
+ ,@body
+ (setq ,var ((guile-primitive 1+) ,var)))
+ ,@(if (= (length args) 3)
+ (list (caddr args))
+ '()))))))
+
+(built-in-macro dolist
+ (lambda (args . body)
+ (if (prim or
+ (not (list? args))
+ (< (length args) 2)
+ (> (length args) 3))
+ (macro-error "invalid dolist arguments" args)
+ (let ((var (car args))
+ (iter-list (cadr args))
+ (tailvar (gensym)))
+ (if (not (symbol? var))
+ (macro-error "expected symbol as dolist variable")
+ `(let (,var)
+ (lexical-let ((,tailvar ,iter-list))
+ (while ((guile-primitive not)
+ ((guile-primitive null?) ,tailvar))
+ (setq ,var ((guile-primitive car) ,tailvar))
+ ,@body
+ (setq ,tailvar ((guile-primitive cdr) ,tailvar)))
+ ,@(if (= (length args) 3)
+ (list (caddr args))
+ '()))))))))
+
+;;; Exception handling. unwind-protect and catch are implemented as
+;;; macros (throw is a built-in function).
+
+;;; catch and throw can mainly be implemented directly using Guile's
+;;; primitives for exceptions, the only difficulty is that the keys used
+;;; within Guile must be symbols, while elisp allows any value and
+;;; checks for matches using eq (eq?). We handle this by using always #t
+;;; as key for the Guile primitives and check for matches inside the
+;;; handler; if the elisp keys are not eq?, we rethrow the exception.
+
+(built-in-macro catch
+ (lambda (tag . body)
+ (if (null? body)
+ (macro-error "catch with empty body"))
+ (let ((tagsym (gensym)))
+ `(lexical-let ((,tagsym ,tag))
+ ((guile-primitive catch)
+ #t
+ (lambda () ,@body)
+ ,(let* ((dummy-key (gensym))
+ (elisp-key (gensym))
+ (value (gensym))
+ (arglist `(,dummy-key ,elisp-key ,value)))
+ `(with-always-lexical
+ ,arglist
+ (lambda ,arglist
+ (if (eq ,elisp-key ,tagsym)
+ ,value
+ ((guile-primitive throw) ,dummy-key ,elisp-key
+ ,value))))))))))
+
+;;; unwind-protect is just some weaker construct as dynamic-wind, so
+;;; straight-forward to implement.
+
+(built-in-macro unwind-protect
+ (lambda (body . clean-ups)
+ (if (null? clean-ups)
+ (macro-error "unwind-protect without cleanup code"))
+ `((guile-primitive dynamic-wind)
+ (lambda () nil)
+ (lambda () ,body)
+ (lambda () ,@clean-ups))))
+
+;;; Pop off the first element from a list or push one to it.
+
+(built-in-macro pop
+ (lambda (list-name)
+ `(prog1 (car ,list-name)
+ (setq ,list-name (cdr ,list-name)))))
+
+(built-in-macro push
+ (lambda (new-el list-name)
+ `(setq ,list-name (cons ,new-el ,list-name))))
diff --git a/module/language/elisp/runtime/subrs.scm
b/module/language/elisp/runtime/subrs.scm
new file mode 100644
index 0000000..b03a510
--- /dev/null
+++ b/module/language/elisp/runtime/subrs.scm
@@ -0,0 +1,383 @@
+;;; Guile Emacs Lisp
+
+;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This library 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
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;;; 02110-1301 USA
+
+;;; Code:
+
+(define-module (language elisp runtime subrs)
+ #:use-module (language elisp runtime)
+ #:use-module (system base compile))
+
+;;; This module contains the function-slots of elisp symbols. Elisp
+;;; built-in functions are implemented as predefined function bindings
+;;; here.
+
+;;; Equivalence and equalness predicates.
+
+(built-in-func eq
+ (lambda (a b)
+ (elisp-bool (eq? a b))))
+
+(built-in-func equal
+ (lambda (a b)
+ (elisp-bool (equal? a b))))
+
+;;; Number predicates.
+
+(built-in-func floatp
+ (lambda (num)
+ (elisp-bool (and (real? num)
+ (or (inexact? num)
+ (prim not (integer? num)))))))
+
+(built-in-func integerp
+ (lambda (num)
+ (elisp-bool (and (exact? num)
+ (integer? num)))))
+
+(built-in-func numberp
+ (lambda (num)
+ (elisp-bool (real? num))))
+
+(built-in-func wholenump
+ (lambda (num)
+ (elisp-bool (and (exact? num)
+ (integer? num)
+ (prim >= num 0)))))
+
+(built-in-func zerop
+ (lambda (num)
+ (elisp-bool (prim = num 0))))
+
+;;; Number comparisons.
+
+(built-in-func =
+ (lambda (num1 num2)
+ (elisp-bool (prim = num1 num2))))
+
+(built-in-func /=
+ (lambda (num1 num2)
+ (elisp-bool (prim not (prim = num1 num2)))))
+
+(built-in-func <
+ (lambda (num1 num2)
+ (elisp-bool (prim < num1 num2))))
+
+(built-in-func <=
+ (lambda (num1 num2)
+ (elisp-bool (prim <= num1 num2))))
+
+(built-in-func >
+ (lambda (num1 num2)
+ (elisp-bool (prim > num1 num2))))
+
+(built-in-func >=
+ (lambda (num1 num2)
+ (elisp-bool (prim >= num1 num2))))
+
+(built-in-func max
+ (lambda (. nums)
+ (prim apply (@ (guile) max) nums)))
+
+(built-in-func min
+ (lambda (. nums)
+ (prim apply (@ (guile) min) nums)))
+
+(built-in-func abs
+ (@ (guile) abs))
+
+;;; Number conversion.
+
+(built-in-func float
+ (lambda (num)
+ (if (exact? num)
+ (exact->inexact num)
+ num)))
+
+;;; TODO: truncate, floor, ceiling, round.
+
+;;; Arithmetic functions.
+
+(built-in-func 1+ (@ (guile) 1+))
+
+(built-in-func 1- (@ (guile) 1-))
+
+(built-in-func + (@ (guile) +))
+
+(built-in-func - (@ (guile) -))
+
+(built-in-func * (@ (guile) *))
+
+(built-in-func % (@ (guile) modulo))
+
+;;; TODO: / with correct integer/real behaviour, mod (for floating-piont
+;;; values).
+
+;;; Floating-point rounding operations.
+
+(built-in-func ffloor (@ (guile) floor))
+
+(built-in-func fceiling (@ (guile) ceiling))
+
+(built-in-func ftruncate (@ (guile) truncate))
+
+(built-in-func fround (@ (guile) round))
+
+;;; List predicates.
+
+(built-in-func consp
+ (lambda (el)
+ (elisp-bool (pair? el))))
+
+(built-in-func atomp
+ (lambda (el)
+ (elisp-bool (prim not (pair? el)))))
+
+(built-in-func listp
+ (lambda (el)
+ (elisp-bool (or (pair? el) (null? el)))))
+
+(built-in-func nlistp
+ (lambda (el)
+ (elisp-bool (and (prim not (pair? el))
+ (prim not (null? el))))))
+
+(built-in-func null
+ (lambda (el)
+ (elisp-bool (null? el))))
+
+;;; Accessing list elements.
+
+(built-in-func car
+ (lambda (el)
+ (if (null? el)
+ nil-value
+ (prim car el))))
+
+(built-in-func cdr
+ (lambda (el)
+ (if (null? el)
+ nil-value
+ (prim cdr el))))
+
+(built-in-func car-safe
+ (lambda (el)
+ (if (pair? el)
+ (prim car el)
+ nil-value)))
+
+(built-in-func cdr-safe
+ (lambda (el)
+ (if (pair? el)
+ (prim cdr el)
+ nil-value)))
+
+(built-in-func nth
+ (lambda (n lst)
+ (if (negative? n)
+ (prim car lst)
+ (let iterate ((i n)
+ (tail lst))
+ (cond
+ ((null? tail) nil-value)
+ ((zero? i) (prim car tail))
+ (else (iterate (prim 1- i) (prim cdr tail))))))))
+
+(built-in-func nthcdr
+ (lambda (n lst)
+ (if (negative? n)
+ lst
+ (let iterate ((i n)
+ (tail lst))
+ (cond
+ ((null? tail) nil-value)
+ ((zero? i) tail)
+ (else (iterate (prim 1- i) (prim cdr tail))))))))
+
+(built-in-func length (@ (guile) length))
+
+;;; Building lists.
+
+(built-in-func cons (@ (guile) cons))
+
+(built-in-func list (@ (guile) list))
+
+(built-in-func make-list
+ (lambda (len obj)
+ (prim make-list len obj)))
+
+(built-in-func append (@ (guile) append))
+
+(built-in-func reverse (@ (guile) reverse))
+
+(built-in-func copy-tree (@ (guile) copy-tree))
+
+(built-in-func number-sequence
+ (lambda (from . rest)
+ (if (prim > (prim length rest) 2)
+ (runtime-error "too many arguments for number-sequence"
+ (prim cdddr rest))
+ (if (null? rest)
+ `(,from)
+ (let ((to (prim car rest))
+ (sep (if (or (null? (prim cdr rest))
+ (eq? nil-value (prim cadr rest)))
+ 1
+ (prim cadr rest))))
+ (cond
+ ((or (eq? nil-value to) (prim = to from)) `(,from))
+ ((and (zero? sep) (prim not (prim = from to)))
+ (runtime-error "infinite list in number-sequence"))
+ ((prim < (prim * to sep) (prim * from sep)) '())
+ (else
+ (let iterate ((i (prim +
+ from
+ (prim *
+ sep
+ (prim quotient
+ (prim abs
+ (prim -
+ to
+ from))
+ (prim abs sep)))))
+ (result '()))
+ (if (prim = i from)
+ (prim cons i result)
+ (iterate (prim - i sep)
+ (prim cons i result)))))))))))
+
+;;; Changing lists.
+
+(built-in-func setcar
+ (lambda (cell val)
+ (if (and (null? cell) (null? val))
+ #nil
+ (prim set-car! cell val))
+ val))
+
+(built-in-func setcdr
+ (lambda (cell val)
+ (if (and (null? cell) (null? val))
+ #nil
+ (prim set-cdr! cell val))
+ val))
+
+;;; Accessing symbol bindings for symbols known only at runtime.
+
+(built-in-func symbol-value
+ (lambda (sym)
+ (reference-variable value-slot-module sym)))
+
+(built-in-func symbol-function
+ (lambda (sym)
+ (reference-variable function-slot-module sym)))
+
+(built-in-func set
+ (lambda (sym value)
+ (set-variable! value-slot-module sym value)))
+
+(built-in-func fset
+ (lambda (sym value)
+ (set-variable! function-slot-module sym value)))
+
+(built-in-func makunbound
+ (lambda (sym)
+ (if (module-bound? (resolve-interface value-slot-module) sym)
+ (let ((var (module-variable (resolve-module value-slot-module)
+ sym)))
+ (if (and (variable-bound? var) (fluid? (variable-ref var)))
+ (fluid-unset! (variable-ref var))
+ (variable-unset! var))))
+ sym))
+
+(built-in-func fmakunbound
+ (lambda (sym)
+ (if (module-bound? (resolve-interface function-slot-module) sym)
+ (let ((var (module-variable
+ (resolve-module function-slot-module)
+ sym)))
+ (if (and (variable-bound? var) (fluid? (variable-ref var)))
+ (fluid-unset! (variable-ref var))
+ (variable-unset! var))))
+ sym))
+
+(built-in-func boundp
+ (lambda (sym)
+ (elisp-bool
+ (and
+ (module-bound? (resolve-interface value-slot-module) sym)
+ (let ((var (module-variable (resolve-module value-slot-module)
+ sym)))
+ (and (variable-bound? var)
+ (if (fluid? (variable-ref var))
+ (fluid-bound? (variable-ref var))
+ #t)))))))
+
+(built-in-func fboundp
+ (lambda (sym)
+ (elisp-bool
+ (and
+ (module-bound? (resolve-interface function-slot-module) sym)
+ (let* ((var (module-variable (resolve-module function-slot-module)
+ sym)))
+ (and (variable-bound? var)
+ (if (fluid? (variable-ref var))
+ (fluid-bound? (variable-ref var))
+ #t)))))))
+
+;;; Function calls. These must take care of special cases, like using
+;;; symbols or raw lambda-lists as functions!
+
+(built-in-func apply
+ (lambda (func . args)
+ (let ((real-func (cond
+ ((symbol? func)
+ (reference-variable function-slot-module func))
+ ((list? func)
+ (if (and (prim not (null? func))
+ (eq? (prim car func) 'lambda))
+ (compile func #:from 'elisp #:to 'value)
+ (runtime-error "list is not a function"
+ func)))
+ (else func))))
+ (prim apply (@ (guile) apply) real-func args))))
+
+(built-in-func funcall
+ (lambda (func . args)
+ (apply func args)))
+
+;;; Throw can be implemented as built-in function.
+
+(built-in-func throw
+ (lambda (tag value)
+ (prim throw 'elisp-exception tag value)))
+
+;;; Miscellaneous.
+
+(built-in-func not
+ (lambda (x)
+ (if x nil-value t-value)))
+
+(built-in-func eval
+ (lambda (form)
+ (compile form #:from 'elisp #:to 'value)))
+
+(built-in-func load
+ (lambda* (file)
+ (compile-file file #:from 'elisp #:to 'value)
+ #t))
diff --git a/module/language/elisp/runtime/value-slot.scm
b/module/language/elisp/runtime/value-slot.scm
index 056b122..c6cc3b4 100644
--- a/module/language/elisp/runtime/value-slot.scm
+++ b/module/language/elisp/runtime/value-slot.scm
@@ -1,6 +1,6 @@
;;; Guile Emacs Lisp
-;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -20,4 +20,4 @@
(define-module (language elisp runtime value-slot))
-; This module contains the value-slots of elisp symbols.
+;;; This module contains the value-slots of elisp symbols.
diff --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm
index d93208e..3da3680 100644
--- a/module/language/elisp/spec.scm
+++ b/module/language/elisp/spec.scm
@@ -6,12 +6,12 @@
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
-;;;;
+;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
@@ -25,7 +25,7 @@
#:export (elisp))
(define-language elisp
- #:title "Emacs Lisp"
- #:reader (lambda (port env) (read-elisp port))
- #:printer write
- #:compilers `((tree-il . ,compile-tree-il)))
+ #:title "Emacs Lisp"
+ #:reader (lambda (port env) (read-elisp port))
+ #:printer write
+ #:compilers `((tree-il . ,compile-tree-il)))
diff --git a/test-suite/guile-test b/test-suite/guile-test
index 3917395..cdcfe49 100755
--- a/test-suite/guile-test
+++ b/test-suite/guile-test
@@ -1,4 +1,4 @@
-#!../libguile/guile \
+#!../meta/guile \
-e main -s
!#
@@ -92,12 +92,15 @@
;;; User configurable settings:
-(define default-test-suite
- (string-append (getenv "HOME") "/bogus-path/test-suite"))
+(define (default-test-suite)
+ (let ((argv0 (car (program-arguments))))
+ (if (string=? (basename argv0) "guile-test")
+ (dirname argv0)
+ (error "Cannot find default test suite."))))
;;; Variables that will receive their actual values later.
-(define test-suite default-test-suite)
+(define test-suite)
(define tmp-dir #f)
@@ -192,7 +195,7 @@
(set! test-suite
(or (opt 'test-suite #f)
(getenv "TEST_SUITE_DIR")
- default-test-suite))
+ (default-test-suite)))
;; directory where temporary files are created.
;; when run from "make check", this must be under the build-dir,
diff --git a/test-suite/tests/elisp-compiler.test
b/test-suite/tests/elisp-compiler.test
index 61f0acd..230dc77 100644
--- a/test-suite/tests/elisp-compiler.test
+++ b/test-suite/tests/elisp-compiler.test
@@ -26,7 +26,7 @@
; Macros to handle the compilation conveniently.
(define-syntax compile-test
- (syntax-rules (pass-if pass-if-exception)
+ (syntax-rules (pass-if pass-if-equal pass-if-exception)
((_ (pass-if test-name exp))
(pass-if test-name (compile 'exp #:from 'elisp #:to 'value)))
((_ (pass-if test-name exp #:opts opts))
@@ -204,7 +204,7 @@
(progn (setq depth 10 i depth)
(setq code '(eval 0))
(while (not (zerop i))
- (setq code (\` (eval (quote (1+ (\, code))))))
+ (setq code (#{`}# (eval (quote (1+ (#{,}# code))))))
(setq i (1- i)))
(= (eval code) depth))))
@@ -234,17 +234,7 @@
(progn (setq a 1 b 2)
(and (eq (makunbound 'b) 'b)
(boundp 'a)
- (not (boundp 'b)))))
-
- (pass-if "disabled void check (all)"
- (progn (makunbound 'a) a t)
- #:opts '(#:disable-void-check all))
- (pass-if "disabled void check (symbol list)"
- (progn (makunbound 'a) a t)
- #:opts '(#:disable-void-check (x y a b)))
- (pass-if "without-void-checks"
- (progn (makunbound 'a)
- (= (without-void-checks (a) a 5) 5))))
+ (not (boundp 'b))))))
(with-test-prefix/compile "Let and Let*"
@@ -470,13 +460,13 @@
(flet ((foobar (lambda () 0))
(myfoo (symbol-function 'foobar)))
(and (= (myfoo) 42)
- (= (test) 0)))
+ (= (test) 42)))
(flet* ((foobar (lambda () 0))
(myfoo (symbol-function 'foobar)))
- (= (myfoo) 0))
+ (= (myfoo) 42))
(flet (foobar)
(defun foobar () 0)
- (= (test) 0))
+ (= (test) 42))
(= (test) 42)))))
(with-test-prefix/compile "Calling Functions"
@@ -527,19 +517,19 @@
(equal '(1 2 . 3) '(1 2 . 3))))
(pass-if "simple backquote"
- (and (equal (\` 42) 42)
- (equal (\` (1 (a))) '(1 (a)))
- (equal (\` (1 . 2)) '(1 . 2))))
+ (and (equal (#{`}# 42) 42)
+ (equal (#{`}# (1 (a))) '(1 (a)))
+ (equal (#{`}# (1 . 2)) '(1 . 2))))
(pass-if "unquote"
(progn (setq a 42 l '(18 12))
- (and (equal (\` (\, a)) 42)
- (equal (\` (1 a ((\, l)) . (\, a))) '(1 a ((18 12)) . 42)))))
+ (and (equal (#{`}# (#{,}# a)) 42)
+ (equal (#{`}# (1 a ((#{,}# l)) . (#{,}# a))) '(1 a ((18 12)) .
42)))))
(pass-if "unquote splicing"
(progn (setq l '(18 12) empty '())
- (and (equal (\` (\,@ l)) '(18 12))
- (equal (\` (l 2 (3 (\,@ l)) ((\,@ l)) (\,@ l)))
+ (and (equal (#{`}# (#{,@}# l)) '(18 12))
+ (equal (#{`}# (l 2 (3 (#{,@}# l)) ((#{,@}# l)) (#{,@}# l)))
'(l 2 (3 18 12) (18 12) 18 12))
- (equal (\` (1 2 (\,@ empty) 3)) '(1 2 3))))))
+ (equal (#{`}# (1 2 (#{,@}# empty) 3)) '(1 2 3))))))
diff --git a/test-suite/tests/elisp-reader.test
b/test-suite/tests/elisp-reader.test
index fc7cd1b..cf7c15c 100644
--- a/test-suite/tests/elisp-reader.test
+++ b/test-suite/tests/elisp-reader.test
@@ -32,7 +32,7 @@
(define (lex-all lexer)
(let iterate ((result '()))
(let ((token (lexer)))
- (if (eq? token '*eoi*)
+ (if (eq? (car token) 'eof)
(reverse result)
(iterate (cons token result))))))
@@ -43,9 +43,9 @@
(let ((lexer (get-string-lexer "")))
(pass-if "end-of-input"
- (and (eq? (lexer) '*eoi*)
- (eq? (lexer) '*eoi*)
- (eq? (lexer) '*eoi*))))
+ (and (eq? (car (lexer)) 'eof)
+ (eq? (car (lexer)) 'eof)
+ (eq? (car (lexer)) 'eof))))
(pass-if "single character tokens"
(equal? (lex-string "()[]'`,,@ . ")
@@ -125,8 +125,8 @@ test\"ab\"\\ abcd
get-lexer/1)))
(pass-if "lexer/1"
(and (equal? (lex-all lexer) (lex-string lex1-string))
- (eq? (lexer) '*eoi*)
- (eq? (lexer) '*eoi*)))))
+ (eq? (car (lexer)) 'eof)
+ (eq? (car (lexer)) 'eof)))))
;
==============================================================================
@@ -163,7 +163,7 @@ test\"ab\"\\ abcd
(and (equal? (parse-str "'(1 2 3 '4)")
'(quote (1 2 3 (quote 4))))
(equal? (parse-str "`(1 2 ,3 ,@a)")
- '(\` (1 2 (\, 3) (\,@ a))))))
+ '(#{`}# (1 2 (#{,}# 3) (#{,@}# a))))))
(pass-if "lists"
(equal? (parse-str "(1 2 (3) () 4 (. 5) (1 2 . (3 4)) (1 . 2) . 42)")
diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test
index 8604dcb..23406b2 100644
--- a/test-suite/tests/fluids.test
+++ b/test-suite/tests/fluids.test
@@ -147,3 +147,23 @@
(and (eq? inside-a 'inside)
(eq? outside-a 'outside)
(eq? inside-a2 'inside))))))))
+
+(with-test-prefix "unbound fluids"
+ (pass-if "fluid-ref of unbound fluid"
+ (catch #t
+ (lambda () (fluid-ref (make-undefined-fluid)))
+ (lambda (key . args) #t)))
+ (pass-if "fluid-bound? of bound fluid"
+ (fluid-bound? (make-fluid)))
+ (pass-if "fluid-bound? of unbound fluid"
+ (not (fluid-bound? (make-undefined-fluid))))
+ (pass-if "unbound fluids can be set"
+ (let ((fluid (make-undefined-fluid)))
+ (fluid-set! fluid #t)
+ (fluid-ref fluid)))
+ (pass-if "bound fluids can be unset"
+ (let ((fluid (make-fluid)))
+ (fluid-unset! fluid)
+ (catch #t
+ (lambda () (fluid-ref fluid))
+ (lambda (key . args) #t)))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-13-168-gc6920dc,
Andy Wingo <=