summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-10-28 00:07:41 +0100
committerAndy Wingo <wingo@pobox.com>2009-10-28 00:07:41 +0100
commit87dd448006674daf10256d1789230129da345a09 (patch)
treefb542a2401430f4970ad593705f51cbce6e62220
parentb02b05332f45fc6ac4f99556cda9fb7ee894e673 (diff)
parentff810079188b8d04224959d5b54254d3e142d6c3 (diff)
downloadguile-87dd448006674daf10256d1789230129da345a09.tar.gz
merge elisp, but with badness
Diffstat
-rw-r--r--doc/ref/vm.texi4
-rw-r--r--lib/iconv_open-aix.h2
-rw-r--r--libguile/_scm.h2
-rw-r--r--libguile/vm-i-system.c149
-rw-r--r--module/Makefile.am12
-rw-r--r--module/language/assembly.scm2
-rw-r--r--module/language/elisp/README115
-rw-r--r--module/language/elisp/bindings.scm128
-rw-r--r--module/language/elisp/compile-tree-il.scm886
-rw-r--r--module/language/elisp/lexer.scm405
-rw-r--r--module/language/elisp/parser.scm212
-rw-r--r--module/language/elisp/runtime.scm129
-rw-r--r--module/language/elisp/runtime/function-slot.scm314
-rw-r--r--module/language/elisp/runtime/macro-slot.scm205
-rw-r--r--module/language/elisp/runtime/value-slot.scm24
-rw-r--r--module/language/elisp/spec.scm32
-rw-r--r--module/language/glil/decompile-assembly.scm2
-rw-r--r--test-suite/Makefile.am2
-rw-r--r--test-suite/tests/elisp-compiler.test695
-rw-r--r--test-suite/tests/elisp-reader.test185
20 files changed, 3432 insertions, 73 deletions
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index 43b265596..fe5c1eeb4 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -820,6 +820,10 @@ Push @code{#f} onto the stack.
Push @code{#t} onto the stack.
@end deffn
+@deffn Instruction make-nil
+Push @code{%nil} onto the stack.
+@end deffn
+
@deffn Instruction make-eol
Push @code{'()} onto the stack.
@end deffn
diff --git a/lib/iconv_open-aix.h b/lib/iconv_open-aix.h
index 0ffc3fef1..a598e819d 100644
--- a/lib/iconv_open-aix.h
+++ b/lib/iconv_open-aix.h
@@ -229,7 +229,7 @@ static const struct mapping mappings[] =
#ifdef __GNUC__
__inline
-#ifdef __GNUC_STDC_INLINE__
+#if defined __GNUC_STDC_INLINE__ || defined __GNUC_GNU_INLINE__
__attribute__ ((__gnu_inline__))
#endif
#endif
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 33cb375d1..dca491de7 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -172,7 +172,7 @@
/* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 0
-#define SCM_OBJCODE_MINOR_VERSION L
+#define SCM_OBJCODE_MINOR_VERSION M
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index f58ffce58..a29b3f05d 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -105,31 +105,37 @@ VM_DEFINE_INSTRUCTION (7, make_false, "make-false", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (8, make_eol, "make-eol", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (8, make_nil, "make-nil", 0, 0, 1)
+{
+ PUSH (SCM_ELISP_NIL);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (9, make_eol, "make-eol", 0, 0, 1)
{
PUSH (SCM_EOL);
NEXT;
}
-VM_DEFINE_INSTRUCTION (9, make_int8, "make-int8", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (10, make_int8, "make-int8", 1, 0, 1)
{
PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
NEXT;
}
-VM_DEFINE_INSTRUCTION (10, make_int8_0, "make-int8:0", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (11, make_int8_0, "make-int8:0", 0, 0, 1)
{
PUSH (SCM_INUM0);
NEXT;
}
-VM_DEFINE_INSTRUCTION (11, make_int8_1, "make-int8:1", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (12, make_int8_1, "make-int8:1", 0, 0, 1)
{
PUSH (SCM_I_MAKINUM (1));
NEXT;
}
-VM_DEFINE_INSTRUCTION (12, make_int16, "make-int16", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (13, make_int16, "make-int16", 2, 0, 1)
{
int h = FETCH ();
int l = FETCH ();
@@ -137,7 +143,7 @@ VM_DEFINE_INSTRUCTION (12, make_int16, "make-int16", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (13, make_int64, "make-int64", 8, 0, 1)
+VM_DEFINE_INSTRUCTION (14, make_int64, "make-int64", 8, 0, 1)
{
scm_t_uint64 v = 0;
v += FETCH ();
@@ -152,7 +158,7 @@ VM_DEFINE_INSTRUCTION (13, make_int64, "make-int64", 8, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (14, make_uint64, "make-uint64", 8, 0, 1)
+VM_DEFINE_INSTRUCTION (15, make_uint64, "make-uint64", 8, 0, 1)
{
scm_t_uint64 v = 0;
v += FETCH ();
@@ -167,7 +173,7 @@ VM_DEFINE_INSTRUCTION (14, make_uint64, "make-uint64", 8, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (15, make_char8, "make-char8", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0, 1)
{
scm_t_uint8 v = 0;
v = FETCH ();
@@ -179,7 +185,7 @@ VM_DEFINE_INSTRUCTION (15, make_char8, "make-char8", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (16, make_char32, "make-char32", 4, 0, 1)
+VM_DEFINE_INSTRUCTION (17, make_char32, "make-char32", 4, 0, 1)
{
scm_t_wchar v = 0;
v += FETCH ();
@@ -192,7 +198,7 @@ VM_DEFINE_INSTRUCTION (16, make_char32, "make-char32", 4, 0, 1)
-VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1)
+VM_DEFINE_INSTRUCTION (18, list, "list", 2, -1, 1)
{
unsigned h = FETCH ();
unsigned l = FETCH ();
@@ -201,7 +207,7 @@ VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
+VM_DEFINE_INSTRUCTION (19, vector, "vector", 2, -1, 1)
{
unsigned h = FETCH ();
unsigned l = FETCH ();
@@ -241,7 +247,7 @@ VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
/* ref */
-VM_DEFINE_INSTRUCTION (19, object_ref, "object-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (20, object_ref, "object-ref", 1, 0, 1)
{
register unsigned objnum = FETCH ();
CHECK_OBJECT (objnum);
@@ -250,7 +256,7 @@ VM_DEFINE_INSTRUCTION (19, object_ref, "object-ref", 1, 0, 1)
}
/* FIXME: necessary? elt 255 of the vector could be a vector... */
-VM_DEFINE_INSTRUCTION (20, long_object_ref, "long-object-ref", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (21, long_object_ref, "long-object-ref", 2, 0, 1)
{
unsigned int objnum = FETCH ();
objnum <<= 8;
@@ -260,14 +266,14 @@ VM_DEFINE_INSTRUCTION (20, long_object_ref, "long-object-ref", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (21, local_ref, "local-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1)
{
PUSH (LOCAL_REF (FETCH ()));
ASSERT_BOUND (*sp);
NEXT;
}
-VM_DEFINE_INSTRUCTION (22, long_local_ref, "long-local-ref", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (23, long_local_ref, "long-local-ref", 2, 0, 1)
{
unsigned int i = FETCH ();
i <<= 8;
@@ -277,7 +283,7 @@ VM_DEFINE_INSTRUCTION (22, long_local_ref, "long-local-ref", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (24, local_bound, "local-bound?", 1, 0, 1)
{
if (LOCAL_REF (FETCH ()) == SCM_UNDEFINED)
PUSH (SCM_BOOL_F);
@@ -286,7 +292,7 @@ VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (25, long_local_bound, "long-local-bound?", 2, 0, 1)
{
unsigned int i = FETCH ();
i <<= 8;
@@ -298,7 +304,7 @@ VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (26, variable_ref, "variable-ref", 0, 0, 1)
{
SCM x = *sp;
@@ -317,7 +323,7 @@ VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (26, variable_bound, "variable-bound?", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (27, variable_bound, "variable-bound?", 0, 0, 1)
{
if (VARIABLE_BOUNDP (*sp))
*sp = SCM_BOOL_T;
@@ -326,7 +332,7 @@ VM_DEFINE_INSTRUCTION (26, variable_bound, "variable-bound?", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1, 0, 1)
{
unsigned objnum = FETCH ();
SCM what;
@@ -349,7 +355,7 @@ VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (29, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
{
SCM what;
unsigned int objnum = FETCH ();
@@ -376,14 +382,14 @@ VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
/* set */
-VM_DEFINE_INSTRUCTION (29, local_set, "local-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0)
{
LOCAL_SET (FETCH (), *sp);
DROP ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0)
+VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0)
{
unsigned int i = FETCH ();
i <<= 8;
@@ -393,14 +399,14 @@ VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 1, 0)
+VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 1, 0)
{
VARIABLE_SET (sp[0], sp[-1]);
DROPN (2);
NEXT;
}
-VM_DEFINE_INSTRUCTION (32, toplevel_set, "toplevel-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (33, toplevel_set, "toplevel-set", 1, 1, 0)
{
unsigned objnum = FETCH ();
SCM what;
@@ -419,7 +425,7 @@ VM_DEFINE_INSTRUCTION (32, toplevel_set, "toplevel-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
+VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
{
SCM what;
unsigned int objnum = FETCH ();
@@ -465,7 +471,7 @@ VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
NEXT; \
}
-VM_DEFINE_INSTRUCTION (34, br, "br", 3, 0, 0)
+VM_DEFINE_INSTRUCTION (35, br, "br", 3, 0, 0)
{
scm_t_int32 offset;
FETCH_OFFSET (offset);
@@ -473,34 +479,34 @@ VM_DEFINE_INSTRUCTION (34, br, "br", 3, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (35, br_if, "br-if", 3, 0, 0)
+VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 3, 0, 0)
{
BR (scm_is_true_and_not_nil (*sp));
}
-VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0)
+VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 3, 0, 0)
{
BR (scm_is_false_or_nil (*sp));
}
-VM_DEFINE_INSTRUCTION (37, br_if_eq, "br-if-eq", 3, 0, 0)
+VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 3, 0, 0)
{
sp--; /* underflow? */
BR (SCM_EQ_P (sp[0], sp[1]));
}
-VM_DEFINE_INSTRUCTION (38, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
+VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
{
sp--; /* underflow? */
BR (!SCM_EQ_P (sp[0], sp[1]));
}
-VM_DEFINE_INSTRUCTION (39, br_if_null, "br-if-null", 3, 0, 0)
+VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 3, 0, 0)
{
BR (scm_is_null_or_nil (*sp));
}
-VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0)
+VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 3, 0, 0)
{
BR (!scm_is_null_or_nil (*sp));
}
@@ -510,7 +516,7 @@ VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0)
* Subprogram call
*/
-VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0)
+VM_DEFINE_INSTRUCTION (42, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
@@ -522,7 +528,7 @@ VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0)
+VM_DEFINE_INSTRUCTION (43, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
@@ -534,7 +540,7 @@ VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
+VM_DEFINE_INSTRUCTION (44, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
@@ -546,7 +552,7 @@ VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (44, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (45, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
@@ -556,7 +562,7 @@ VM_DEFINE_INSTRUCTION (44, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (45, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (46, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
@@ -566,7 +572,7 @@ VM_DEFINE_INSTRUCTION (45, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (46, bind_optionals, "bind-optionals", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (47, bind_optionals, "bind-optionals", 2, -1, -1)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
@@ -576,7 +582,7 @@ VM_DEFINE_INSTRUCTION (46, bind_optionals, "bind-optionals", 2, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1)
+VM_DEFINE_INSTRUCTION (48, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1)
{
SCM *walk;
scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
@@ -613,7 +619,7 @@ VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6,
NEXT;
}
-VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0)
+VM_DEFINE_INSTRUCTION (49, bind_kwargs, "bind-kwargs", 5, 0, 0)
{
scm_t_uint16 idx;
scm_t_ptrdiff nkw;
@@ -661,7 +667,7 @@ VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (50, push_rest, "push-rest", 2, -1, -1)
{
scm_t_ptrdiff n;
SCM rest = SCM_EOL;
@@ -674,7 +680,7 @@ VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (50, bind_rest, "bind-rest", 4, -1, -1)
+VM_DEFINE_INSTRUCTION (51, bind_rest, "bind-rest", 4, -1, -1)
{
scm_t_ptrdiff n;
scm_t_uint32 i;
@@ -690,7 +696,7 @@ VM_DEFINE_INSTRUCTION (50, bind_rest, "bind-rest", 4, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (51, reserve_locals, "reserve-locals", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (52, reserve_locals, "reserve-locals", 2, -1, -1)
{
SCM *old_sp;
scm_t_int32 n;
@@ -711,7 +717,7 @@ VM_DEFINE_INSTRUCTION (51, reserve_locals, "reserve-locals", 2, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3)
+VM_DEFINE_INSTRUCTION (53, new_frame, "new-frame", 0, 0, 3)
{
/* NB: if you change this, see frames.c:vm-frame-num-locals */
/* and frames.h, vm-engine.c, etc of course */
@@ -721,7 +727,7 @@ VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3)
NEXT;
}
-VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (54, call, "call", 1, -1, 1)
{
SCM x;
nargs = FETCH ();
@@ -782,7 +788,7 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (54, goto_args, "goto/args", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (55, goto_args, "goto/args", 1, -1, 1)
{
register SCM x;
nargs = FETCH ();
@@ -855,7 +861,7 @@ VM_DEFINE_INSTRUCTION (54, goto_args, "goto/args", 1, -1, 1)
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (55, goto_nargs, "goto/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (56, goto_nargs, "goto/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -864,7 +870,7 @@ VM_DEFINE_INSTRUCTION (55, goto_nargs, "goto/nargs", 0, 0, 1)
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (56, call_nargs, "call/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (57, call_nargs, "call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -873,7 +879,7 @@ VM_DEFINE_INSTRUCTION (56, call_nargs, "call/nargs", 0, 0, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (57, mv_call, "mv-call", 4, -1, 1)
+VM_DEFINE_INSTRUCTION (58, mv_call, "mv-call", 4, -1, 1)
{
SCM x;
scm_t_int32 offset;
@@ -935,7 +941,7 @@ VM_DEFINE_INSTRUCTION (57, mv_call, "mv-call", 4, -1, 1)
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (58, apply, "apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (59, apply, "apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -954,7 +960,7 @@ VM_DEFINE_INSTRUCTION (58, apply, "apply", 1, -1, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (59, goto_apply, "goto/apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (60, goto_apply, "goto/apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -973,7 +979,7 @@ VM_DEFINE_INSTRUCTION (59, goto_apply, "goto/apply", 1, -1, 1)
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (60, call_cc, "call/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (61, call_cc, "call/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -1010,7 +1016,7 @@ VM_DEFINE_INSTRUCTION (60, call_cc, "call/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (61, goto_cc, "goto/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (62, goto_cc, "goto/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -1042,7 +1048,7 @@ VM_DEFINE_INSTRUCTION (61, goto_cc, "goto/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (62, return, "return", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (63, return, "return", 0, 1, 1)
{
vm_return:
EXIT_HOOK ();
@@ -1078,7 +1084,7 @@ VM_DEFINE_INSTRUCTION (62, return, "return", 0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (63, return_values, "return/values", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (64, return_values, "return/values", 1, -1, -1)
{
/* nvalues declared at top level, because for some reason gcc seems to think
that perhaps it might be used without declaration. Fooey to that, I say. */
@@ -1133,7 +1139,7 @@ VM_DEFINE_INSTRUCTION (63, return_values, "return/values", 1, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (64, return_values_star, "return/values*", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (65, return_values_star, "return/values*", 1, -1, -1)
{
SCM l;
@@ -1156,7 +1162,7 @@ VM_DEFINE_INSTRUCTION (64, return_values_star, "return/values*", 1, -1, -1)
goto vm_return_values;
}
-VM_DEFINE_INSTRUCTION (65, truncate_values, "truncate-values", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (66, truncate_values, "truncate-values", 2, -1, -1)
{
SCM x;
int nbinds, rest;
@@ -1179,7 +1185,7 @@ VM_DEFINE_INSTRUCTION (65, truncate_values, "truncate-values", 2, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (66, box, "box", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (67, box, "box", 1, 1, 0)
{
SCM val;
POP (val);
@@ -1193,7 +1199,7 @@ VM_DEFINE_INSTRUCTION (66, box, "box", 1, 1, 0)
(set! a (lambda () (b ...)))
...)
*/
-VM_DEFINE_INSTRUCTION (67, empty_box, "empty-box", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (68, empty_box, "empty-box", 1, 0, 0)
{
SYNC_BEFORE_GC ();
LOCAL_SET (FETCH (),
@@ -1201,7 +1207,7 @@ VM_DEFINE_INSTRUCTION (67, empty_box, "empty-box", 1, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (68, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (69, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
{
SCM v = LOCAL_REF (FETCH ());
ASSERT_BOUND_VARIABLE (v);
@@ -1209,7 +1215,7 @@ VM_DEFINE_INSTRUCTION (68, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (69, local_boxed_set, "local-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (70, local_boxed_set, "local-boxed-set", 1, 1, 0)
{
SCM v, val;
v = LOCAL_REF (FETCH ());
@@ -1219,7 +1225,7 @@ VM_DEFINE_INSTRUCTION (69, local_boxed_set, "local-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (70, free_ref, "free-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (71, free_ref, "free-ref", 1, 0, 1)
{
scm_t_uint8 idx = FETCH ();
@@ -1230,7 +1236,7 @@ VM_DEFINE_INSTRUCTION (70, free_ref, "free-ref", 1, 0, 1)
/* no free-set -- if a var is assigned, it should be in a box */
-VM_DEFINE_INSTRUCTION (71, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (72, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
{
SCM v;
scm_t_uint8 idx = FETCH ();
@@ -1241,7 +1247,7 @@ VM_DEFINE_INSTRUCTION (71, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (72, free_boxed_set, "free-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (73, free_boxed_set, "free-boxed-set", 1, 1, 0)
{
SCM v, val;
scm_t_uint8 idx = FETCH ();
@@ -1253,7 +1259,7 @@ VM_DEFINE_INSTRUCTION (72, free_boxed_set, "free-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (73, make_closure, "make-closure", 0, 2, 1)
+VM_DEFINE_INSTRUCTION (74, make_closure, "make-closure", 0, 2, 1)
{
SCM vect;
POP (vect);
@@ -1264,7 +1270,7 @@ VM_DEFINE_INSTRUCTION (73, make_closure, "make-closure", 0, 2, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (74, make_variable, "make-variable", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (75, make_variable, "make-variable", 0, 0, 1)
{
SYNC_BEFORE_GC ();
/* fixme underflow */
@@ -1272,7 +1278,7 @@ VM_DEFINE_INSTRUCTION (74, make_variable, "make-variable", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (75, fix_closure, "fix-closure", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (76, fix_closure, "fix-closure", 2, 0, 1)
{
SCM x, vect;
unsigned int i = FETCH ();
@@ -1286,7 +1292,7 @@ VM_DEFINE_INSTRUCTION (75, fix_closure, "fix-closure", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (76, define, "define", 0, 0, 2)
+VM_DEFINE_INSTRUCTION (77, define, "define", 0, 0, 2)
{
SCM sym, val;
POP (sym);
@@ -1298,7 +1304,7 @@ VM_DEFINE_INSTRUCTION (76, define, "define", 0, 0, 2)
NEXT;
}
-VM_DEFINE_INSTRUCTION (77, make_keyword, "make-keyword", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (78, make_keyword, "make-keyword", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
@@ -1306,7 +1312,7 @@ VM_DEFINE_INSTRUCTION (77, make_keyword, "make-keyword", 0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (78, make_symbol, "make-symbol", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (79, make_symbol, "make-symbol", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
@@ -1325,6 +1331,7 @@ VM_DEFINE_INSTRUCTION (78, make_symbol, "make-symbol", 0, 1, 1)
(replace-match
(number-to-string (setq counter (1+ counter)))
t t nil 1)))))
+(renumber-ops)
*/
/*
Local Variables:
diff --git a/module/Makefile.am b/module/Makefile.am
index d205e0f19..ff51559e0 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -52,6 +52,7 @@ SOURCES = \
$(SYSTEM_SOURCES) \
$(SCRIPTS_SOURCES) \
$(ECMASCRIPT_LANG_SOURCES) \
+ $(ELISP_LANG_SOURCES) \
$(BRAINFUCK_LANG_SOURCES)
## test.scm is not currently installed.
@@ -111,6 +112,17 @@ ECMASCRIPT_LANG_SOURCES = \
language/ecmascript/compile-tree-il.scm \
language/ecmascript/spec.scm
+ELISP_LANG_SOURCES = \
+ language/elisp/lexer.scm \
+ language/elisp/parser.scm \
+ language/elisp/bindings.scm \
+ 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/spec.scm
+
BRAINFUCK_LANG_SOURCES = \
language/brainfuck/parse.scm \
language/brainfuck/compile-scheme.scm \
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index a7c47492e..541096c52 100644
--- a/module/language/assembly.scm
+++ b/module/language/assembly.scm
@@ -108,6 +108,7 @@
(define (object->assembly x)
(cond ((eq? x #t) `(make-true))
((eq? x #f) `(make-false))
+ ((eq? x %nil) `(make-nil))
((null? x) `(make-eol))
((and (integer? x) (exact? x))
(cond ((and (<= -128 x) (< x 128))
@@ -137,6 +138,7 @@
(pmatch code
((make-true) #t)
((make-false) #f) ;; FIXME: Same as the `else' case!
+ ((make-nil) %nil)
((make-eol) '())
((make-int8 ,n)
(if (< n 128) n (- n 256)))
diff --git a/module/language/elisp/README b/module/language/elisp/README
new file mode 100644
index 000000000..4f33711de
--- /dev/null
+++ b/module/language/elisp/README
@@ -0,0 +1,115 @@
+Guile's Emacs Lisp compiler
+===========================
+
+This is more or less a lot of work in progress. Here are some notes as well
+as status information.
+
+Already implemented:
+ * progn, prog1, prog2
+ * if, cond, when, unless
+ * not, and, or
+ * referencing and setting (setq) variables
+ * set, symbol-value, makunbound, boundp functions
+ * fset, symbol-function, fmakunbound, fboundp
+ * funcall, apply (also with raw lists as arguments and the like!)
+ * eval
+ * while, dotimes, dolist
+ * catch, throw, unwind-protect
+ * let, let*
+ * lambda expressions, function calls using list notation
+ * some built-ins (mainly numbers/arithmetic)
+ * defconst, defvar, defun
+ * macros
+ * quotation and backquotation with unquote/unquote-splicing
+ * specific elisp reader
+
+Especially still missing:
+ * more general built-ins
+ * advice?
+ * defsubst and inlining
+ * recursive macros
+ * anonymous macros
+
+Other ideas and things to think about:
+ * %nil vs. #f/'() handling in Guile
+
+Compiler options implemented:
+ * #:disable-void-check ['all / '(sym1 sym2 sym3)] to disable the check
+ for void value on access either completely or for some symbols
+ * #:always-lexical (usable same as disable-void-check) to always bind
+ certain or all symbols lexically (including lambda arguments)
+
+Extensions over original elisp:
+ * guile-ref, guile-primitive
+ * flet and flet*
+ * lexical-let and lexical-let*
+ * without-void-checks, with-always-lexical
+
+
+Details to the implemented extensions
+=====================================
+
+guile-ref and guile-primitive:
+------------------------------
+
+(guile-ref module sym) is a new special construct to access symbols from the
+Guile-world. Actually, (guile-ref module sym) is the same as (@ module sym)
+would be in Scheme. Both module and sym must be statically given and are not
+evaluated.
+
+(guile-primitive sym) does the same to access a Guile primitive directly, which
+is slightly faster where applicable.
+
+flet and flet*:
+---------------
+
+These constructs behave exactly like let and let*, except that they bind the
+function slots rather than the value slots, and so make dynamic scoping
+available for functions, too.
+
+The distinction between flet and flet* is probably less useful than the one
+between let and let*, but it was easy to implement both flet and flet*
+based on the existing let and let* code, so not having both of them seemed
+a little inconsistent.
+
+lexical-let and lexical-let*:
+-----------------------------
+
+lexical-let and lexical-let* are constructs provided by the elisp package
+'cl originally, but in Guile they are natively implemented because using
+lexical instead of dynamic binding gives better performance in this case.
+
+They work just like let and let*, but bind their target symbols lexically.
+Some oberservations with the Emacs 'cl implementation that we mimic in Guile
+for compatibility:
+
+ * Ordinary let's within the lexical scope of a lexical-let still establish new
+ *lexical* bindings for symbols already lexically bound. So once lexical,
+ always lexical (on a per-symbol basis).
+
+ * However, lambda constructs within the lexical scope of a lexical-let where
+ one of their arguments is already lexically bound still bind it dynamically
+ for their scope.
+
+ * On the other hand, symbols lexically bound that are not rebound via the
+ argument-list build lexical closures just well.
+
+ * If symbols are accessed where they are not known at compile-time (like
+ symbol-value or set primitives), this always refers to the dynamic binding
+ and never the lexical one. That's very nice to the implementor...
+
+without-void-checks:
+--------------------
+
+Disable void checks in addition to the compiler option for all or some symbols
+in the lexical scope of this construct:
+
+(without-void-checks all body...) or
+(without-void-checks (sym1 sym2 ...) body...
+
+with-always-lexical:
+--------------------
+
+As without-void-checks but adds to list of symbols that should always be bound
+lexically. This lexical binding includes lambda arguments (if the symbols
+match up with the list), which can not be bound lexically otherwise.
diff --git a/module/language/elisp/bindings.scm b/module/language/elisp/bindings.scm
new file mode 100644
index 000000000..c7937b333
--- /dev/null
+++ b/module/language/elisp/bindings.scm
@@ -0,0 +1,128 @@
+;;; Guile Emac Lisp
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; 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,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language elisp bindings)
+ #:export (make-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.
+
+
+; Record type used to hold the data necessary.
+
+(define bindings-type
+ (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.
+
+(define (make-bindings)
+ ((record-constructor bindings-type) '() (make-hash-table)))
+
+
+; 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))
+ (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)))
+ (new-needed (assoc-set! old-needed module new-in-module)))
+ ((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.
+
+(define (map-globals-needed bindings proc)
+ (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.
+
+(define (get-lexical-binding bindings sym)
+ (let* ((lex ((record-accessor bindings-type 'lexical-bindings) bindings))
+ (slot (hash-ref lex sym #f)))
+ (if slot
+ (fluid-ref slot)
+ #f)))
+
+
+; 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)))
+ (for-each (lambda (sym)
+ (if (not (hash-ref lex sym))
+ (hash-set! lex sym (make-fluid))))
+ 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)))
+
+(define (with-dynamic-bindings bindings syms proc)
+ (with-symbol-bindings bindings
+ 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
new file mode 100644
index 000000000..caa0a30c3
--- /dev/null
+++ b/module/language/elisp/compile-tree-il.scm
@@ -0,0 +1,886 @@
+;;; Guile Emacs Lisp
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, 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,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language elisp compile-tree-il)
+ #:use-module (language elisp bindings)
+ #:use-module (language tree-il)
+ #:use-module (system base pmatch)
+ #:use-module (system base compile)
+ #:use-module (srfi srfi-1)
+ #:export (compile-tree-il))
+
+
+; 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.
+(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))
+
+
+; Find the source properties of some parsed expression if there are any
+; associated with it.
+
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (not (null? props))
+ props))))
+
+
+; Values to use for Elisp's nil and t.
+
+(define (nil-value loc) (make-const loc (@ (language elisp runtime) nil-value)))
+(define (t-value loc) (make-const loc (@ (language elisp runtime) t-value)))
+
+
+; 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))
+
+
+; 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 (backquote? sym)
+ (and (symbol? sym) (eq? sym '\`)))
+
+(define (unquote? sym)
+ (and (symbol? sym) (eq? sym '\,)))
+
+(define (unquote-splicing? sym)
+ (and (symbol? sym) (eq? sym '\,@)))
+
+
+; 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.
+
+(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)))
+
+
+; 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.
+
+(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 '() '() #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)
+ (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
+ (if (and lexical (equal? module value-slot))
+ (handle-lexical lexical)
+ (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.
+
+(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.
+
+(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) ...).
+
+(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")
+ (if (not (symbol? (car b)))
+ (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.
+
+(define (bind-lexically? sym module)
+ (or (eq? module 'lexical)
+ (and (equal? module value-slot)
+ (let ((always (fluid-ref always-lexical)))
+ (or (eq? always 'all)
+ (memq sym always)
+ (get-lexical-binding (fluid-ref bindings-data) sym))))))
+
+(define (split-let-bindings bindings module)
+ (let iterate ((tail bindings)
+ (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.
+(define (generate-let loc module bindings body)
+ (let ((bind (process-let-bindings loc bindings)))
+ (call-with-values
+ (lambda ()
+ (split-let-bindings bind module))
+ (lambda (lexical dynamic)
+ (for-each (lambda (sym)
+ (mark-global-needed! (fluid-ref bindings-data) sym module))
+ (map car dynamic))
+ (let ((make-values (lambda (for)
+ (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.
+(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)))
+ (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
+
+(define (bind-arg-lexical? arg)
+ (let ((always (fluid-ref always-lexical)))
+ (or (eq? always 'all)
+ (memq arg always))))
+
+(define (split-lambda-arguments loc args)
+ (let iterate ((tail args)
+ (mode 'required)
+ (required '())
+ (optional '())
+ (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))
+ (let* ((arg (car tail))
+ (bind-lexical (bind-arg-lexical? arg))
+ (new-lexical (if bind-lexical
+ (cons arg lexical)
+ lexical))
+ (new-dynamic (if bind-lexical
+ dynamic
+ (cons arg dynamic))))
+ (case mode
+ ((required) (iterate (cdr tail) mode
+ (cons arg required) optional
+ new-lexical new-dynamic))
+ ((optional) (iterate (cdr tail) mode
+ 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.
+
+(define (compile-lambda loc args body)
+ (if (not (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
+ (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 rest-name #f '() (append required-sym (list rest-sym))
+ #f
+ (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.
+
+(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.
+
+(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.
+
+(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.
+
+(define (with-added-symbols loc fluid syms body)
+ (if (null? 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))
+ (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)
+ (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)
+ (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)))
+ (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)
+ (let* ((itersym (gensym))
+ (compiled-body (map compile-expr body))
+ (iter-call (make-application loc
+ (make-lexical-ref loc 'iterate itersym)
+ (list)))
+ (full-body (make-sequence loc
+ `(,@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 '() '() #f
+ lambda-body #f))))
+ (make-letrec loc '(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-lambda loc args body))
+
+ ; 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)
+ (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)
+ (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.
+
+(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)))))
+
+
+; Process the compiler options.
+; FIXME: Why is '(()) passed as options by the REPL?
+
+(define (valid-symbol-list-arg? value)
+ (or (eq? value 'all)
+ (and (list? value) (and-map symbol? value))))
+
+(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.
+
+(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))
diff --git a/module/language/elisp/lexer.scm b/module/language/elisp/lexer.scm
new file mode 100644
index 000000000..4aecca664
--- /dev/null
+++ b/module/language/elisp/lexer.scm
@@ -0,0 +1,405 @@
+;;; Guile Emac Lisp
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; 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,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language elisp lexer)
+ #: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: #@count comments
+
+
+; 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.
+
+(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.
+
+(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?.
+
+(define (real-character chr)
+ (if (< chr 256)
+ (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.
+
+(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.
+
+(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.
+
+(define basic-escape-codes
+ '((#\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))))
+ (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
+ (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))
+ ((#\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.
+
+(define integer-regex (make-regexp "^[+-]?[0-9]+\\.?$"))
+(define float-regex
+ (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.
+(define no-escape-punctuation (string->char-set "-+=*/_~!@$%^&:<>{}?."))
+
+(define (get-symbol-or-number port)
+ (let iterate ((result-chars '())
+ (had-escape #f))
+ (let* ((c (read-char port))
+ (finish (lambda ()
+ (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))))
+ (need-no-escape? (lambda (c)
+ (or (char-numeric? c)
+ (char-alphabetic? 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))))))
+
+
+; 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 (id type)
+ (case type
+ ((#\#) `(circular-ref . ,id))
+ ((#\=) `(circular-def . ,id))
+ (else (lexer-error port "invalid circular marker character" type))))))
+
+
+; 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))
+ (line (1+ (port-line port)))
+ (column (1+ (port-column port))))
+ (lambda (token value)
+ (let ((obj (cons token value)))
+ (set-source-property! obj 'filename file)
+ (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.
+ (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))
+ (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) #\@)
+ (if (not (char=? (read-char port) #\@))
+ (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.
+
+(define (get-lexer 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.
+
+(define (get-lexer/1 port)
+ (let ((lex (get-lexer port))
+ (finished #f)
+ (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)))))
diff --git a/module/language/elisp/parser.scm b/module/language/elisp/parser.scm
new file mode 100644
index 000000000..04229d892
--- /dev/null
+++ b/module/language/elisp/parser.scm
@@ -0,0 +1,212 @@
+;;; Guile Emac Lisp
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; 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,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language elisp parser)
+ #: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.
+
+
+; 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!).
+
+(define circular-definitions (make-fluid))
+
+(define (make-circular-definitions)
+ (make-hash-table))
+
+(define (circular-ref token)
+ (if (not (eq? (car token) 'circular-ref))
+ (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))))
+
+; 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))
+ (let ((value #f)
+ (table (fluid-ref circular-definitions))
+ (id (cdr token)))
+ (hashq-set! table id (delay value))
+ (lambda (real-value)
+ (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!
+(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.
+
+(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.
+
+(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.
+
+(define quotation-symbols '((quote . quote)
+ (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)))
+ result)))
+ (case type
+ ((integer float symbol character string)
+ (return (cdr token)))
+ ((quote backquote unquote unquote-splicing)
+ (return (list (assq-ref quotation-symbols type) (get-expression lex))))
+ ((paren-open)
+ (return (get-list lex #t #f)))
+ ((square-open)
+ (return (list->vector (get-list lex #f #t))))
+ ((circular-ref)
+ (circular-ref token))
+ ((circular-def)
+ ; 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)))))
+
+
+; 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)))
diff --git a/module/language/elisp/runtime.scm b/module/language/elisp/runtime.scm
new file mode 100644
index 000000000..bad9b38c4
--- /dev/null
+++ b/module/language/elisp/runtime.scm
@@ -0,0 +1,129 @@
+;;; Guile Emac Lisp
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; 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,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language elisp runtime)
+ #:export (void
+ nil-value t-value
+ value-slot-module function-slot-module
+
+ elisp-bool
+
+ ensure-fluid! reference-variable reference-variable-with-check
+ set-variable!
+
+ 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))
+
+
+; Values for t and nil.
+
+; FIXME: Use real nil.
+(define nil-value #f)
+(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!
+
+(define value-slot-module '(language elisp runtime value-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.
+
+(define (macro-error msg . args)
+ (apply error msg args))
+
+(define runtime-error macro-error)
+
+
+; Convert a scheme boolean to Elisp.
+
+(define (elisp-bool b)
+ (if b
+ 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!
+
+(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))))))
+
+(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)))
+
+(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.
+
+(define-syntax built-in-func
+ (syntax-rules ()
+ ((_ name value)
+ (begin
+ (define-public name (make-fluid))
+ (fluid-set! name value)))))
+
+(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.
+
+(define-syntax prim
+ (syntax-rules ()
+ ((_ sym args ...)
+ ((@ (guile) sym) args ...))))
diff --git a/module/language/elisp/runtime/function-slot.scm b/module/language/elisp/runtime/function-slot.scm
new file mode 100644
index 000000000..79eaeaf64
--- /dev/null
+++ b/module/language/elisp/runtime/function-slot.scm
@@ -0,0 +1,314 @@
+;;; Guile Emac Lisp
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; 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,
+;; Boston, MA 02111-1307, 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)))
diff --git a/module/language/elisp/runtime/macro-slot.scm b/module/language/elisp/runtime/macro-slot.scm
new file mode 100644
index 000000000..2017fd45d
--- /dev/null
+++ b/module/language/elisp/runtime/macro-slot.scm
@@ -0,0 +1,205 @@
+;;; Guile Emac Lisp
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; 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,
+;; Boston, MA 02111-1307, 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
+ (lambda (. args)
+ (if (null? args)
+ 't
+ (let iterate ((tail args))
+ (if (null? (cdr tail))
+ (car tail)
+ `(if ,(car tail)
+ ,(iterate (cdr tail))
+ nil))))))
+
+(built-in-macro or
+ (lambda (. args)
+ (let iterate ((tail args))
+ (if (null? tail)
+ 'nil
+ (let ((var (gensym)))
+ `(without-void-checks (,var)
+ (lexical-let ((,var ,(car tail)))
+ (if ,var
+ ,var
+ ,(iterate (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/value-slot.scm b/module/language/elisp/runtime/value-slot.scm
new file mode 100644
index 000000000..201813a62
--- /dev/null
+++ b/module/language/elisp/runtime/value-slot.scm
@@ -0,0 +1,24 @@
+;;; Guile Emac Lisp
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; 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,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language elisp runtime value-slot))
+
+; This module contains the value-slots of elisp symbols.
diff --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm
new file mode 100644
index 000000000..072ccb9a4
--- /dev/null
+++ b/module/language/elisp/spec.scm
@@ -0,0 +1,32 @@
+;;; Guile Emac Lisp
+
+;; Copyright (C) 2001, 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 spec)
+ #:use-module (language elisp compile-tree-il)
+ #:use-module (language elisp parser)
+ #:use-module (system base language)
+ #:export (elisp))
+
+(define-language elisp
+ #:title "Emacs Lisp"
+ #:version "0.0"
+ #:reader (lambda (port env) (read-elisp port))
+ #:printer write
+ #:compilers `((tree-il . ,compile-tree-il)))
diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm
index 937a67858..916353818 100644
--- a/module/language/glil/decompile-assembly.scm
+++ b/module/language/glil/decompile-assembly.scm
@@ -122,6 +122,8 @@
(lp (cdr in) stack out (1+ pos)))
((make-false)
(lp (cdr in) (cons #f stack) out (1+ pos)))
+ ((make-nil)
+ (lp (cdr in) (cons %nil stack) out (1+ pos)))
((load-program ,labels ,sublen ,meta . ,body)
(lp (cdr in)
(cons (decompile-load-program (decompile-meta meta)
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 145975c9b..895a6b9ff 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -33,6 +33,8 @@ SCM_TESTS = tests/alist.test \
tests/common-list.test \
tests/continuations.test \
tests/elisp.test \
+ tests/elisp-compiler.text \
+ tests/elisp-reader.text \
tests/eval.test \
tests/exceptions.test \
tests/filesys.test \
diff --git a/test-suite/tests/elisp-compiler.test b/test-suite/tests/elisp-compiler.test
new file mode 100644
index 000000000..3d3bb1d6e
--- /dev/null
+++ b/test-suite/tests/elisp-compiler.test
@@ -0,0 +1,695 @@
+;;;; elisp-compiler.test --- Test the compiler for Elisp.
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Daniel Kraft
+;;;;
+;;;; 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
+
+(define-module (test-elisp-compiler)
+ :use-module (test-suite lib)
+ :use-module (system base compile)
+ :use-module (language elisp runtime))
+
+
+; Macros to handle the compilation conveniently.
+
+(define-syntax compile-test
+ (syntax-rules (pass-if 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))
+ (pass-if test-name (compile 'exp #:from 'elisp #:to 'value #:opts opts)))
+ ((_ (pass-if-equal test-name result exp))
+ (pass-if test-name (equal? result
+ (compile 'exp #:from 'elisp #:to 'value))))
+ ((_ (pass-if-exception test-name exc exp))
+ (pass-if-exception test-name exc
+ (compile 'exp #:from 'elisp #:to 'value)))))
+
+(define-syntax with-test-prefix/compile
+ (syntax-rules ()
+ ((_ section-name exp ...)
+ (with-test-prefix section-name (compile-test exp) ...))))
+
+
+; Test control structures.
+; ========================
+
+(with-test-prefix/compile "Sequencing"
+
+ (pass-if-equal "progn" 1
+ (progn (setq a 0)
+ (setq a (1+ a))
+ a))
+
+ (pass-if "prog1"
+ (progn (setq a 0)
+ (setq b (prog1 a (setq a (1+ a))))
+ (and (= a 1) (= b 0))))
+
+ (pass-if "prog2"
+ (progn (setq a 0)
+ (setq b (prog2 (setq a (1+ a))
+ (setq a (1+ a))
+ (setq a (1+ a))))
+ (and (= a 3) (= b 2)))))
+
+(with-test-prefix/compile "Conditionals"
+
+ (pass-if-equal "succeeding if" 1
+ (if t 1 2))
+ (pass-if "failing if"
+ (and (= (if nil
+ 1
+ (setq a 2) (setq a (1+ a)) a)
+ 3)
+ (equal (if nil 1) nil)))
+
+ (pass-if-equal "failing when" nil-value
+ (when nil 1 2 3))
+ (pass-if-equal "succeeding when" 42
+ (progn (setq a 0)
+ (when t (setq a 42) a)))
+
+ (pass-if-equal "failing unless" nil-value
+ (unless t 1 2 3))
+ (pass-if-equal "succeeding unless" 42
+ (progn (setq a 0)
+ (unless nil (setq a 42) a)))
+
+ (pass-if-equal "empty cond" nil-value
+ (cond))
+ (pass-if-equal "all failing cond" nil-value
+ (cond (nil) (nil)))
+ (pass-if-equal "only condition" 5
+ (cond (nil) (5)))
+ (pass-if-equal "succeeding cond value" 42
+ (cond (nil) (t 42) (t 0)))
+ (pass-if-equal "succeeding cond side-effect" 42
+ (progn (setq a 0)
+ (cond (nil) (t (setq a 42) 1) (t (setq a 0)))
+ a)))
+
+(with-test-prefix/compile "Combining Conditions"
+
+ (pass-if-equal "empty and" t-value (and))
+ (pass-if-equal "failing and" nil-value (and 1 2 nil 3))
+ (pass-if-equal "succeeding and" 3 (and 1 2 3))
+
+ (pass-if-equal "empty or" nil-value (or))
+ (pass-if-equal "failing or" nil-value (or nil nil nil))
+ (pass-if-equal "succeeding or" 1 (or nil 1 nil 2 nil 3))
+
+ (pass-if-equal "not true" nil-value (not 1))
+ (pass-if-equal "not false" t-value (not nil)))
+
+(with-test-prefix/compile "Iteration"
+
+ (pass-if-equal "failing while" 0
+ (progn (setq a 0)
+ (while nil (setq a 1))
+ a))
+ (pass-if-equal "running while" 120
+ (progn (setq prod 1
+ i 1)
+ (while (<= i 5)
+ (setq prod (* i prod))
+ (setq i (1+ i)))
+ prod))
+
+ (pass-if "dotimes"
+ (progn (setq a 0)
+ (setq count 100)
+ (setq b (dotimes (i count)
+ (setq j (1+ i))
+ (setq a (+ a j))))
+ (setq c (dotimes (i 10 42) nil))
+ (and (= a 5050) (equal b nil) (= c 42))))
+
+ (pass-if "dolist"
+ (let ((mylist '(7 2 5)))
+ (setq sum 0)
+ (setq a (dolist (i mylist)
+ (setq sum (+ sum i))))
+ (setq b (dolist (i mylist 5) 0))
+ (and (= sum (+ 7 2 5))
+ (equal a nil)
+ (equal mylist '(7 2 5))
+ (equal b 5)))))
+
+(with-test-prefix/compile "Exceptions"
+
+ (pass-if "catch without exception"
+ (and (setq a 0)
+ (= (catch 'foobar
+ (setq a (1+ a))
+ (setq a (1+ a))
+ a)
+ 2)
+ (= (catch (+ 1 2) a) 2)))
+
+ ; FIXME: Figure out how to do this...
+ ;(pass-if-exception "uncaught exception" 'elisp-exception
+ ; (throw 'abc 1))
+
+ (pass-if "catch and throw"
+ (and (setq mylist '(1 2))
+ (= (catch 'abc (throw 'abc 2) 1) 2)
+ (= (catch 'abc (catch 'def (throw 'abc (1+ 0)) 2) 3) 1)
+ (= (catch 'abc (catch 'def (throw 'def 1) 2) 3) 3)
+ (= (catch mylist (catch '(1 2) (throw mylist 1) 2) 3) 1)))
+
+ (pass-if "unwind-protect"
+ (progn (setq a 0 b 1 c 1)
+ (catch 'exc
+ (unwind-protect (progn (setq a 1)
+ (throw 'exc 0))
+ (setq a 0)
+ (setq b 0)))
+ (unwind-protect nil (setq c 0))
+ (and (= a 0) (= b 0) (= c 0)
+ (= (unwind-protect 42 1 2 3) 42)))))
+
+(with-test-prefix/compile "Eval"
+
+ (pass-if-equal "basic eval" 3
+ (progn (setq code '(+ 1 2))
+ (eval code)))
+
+ (pass-if "real dynamic code"
+ (and (setq a 1 b 1 c 1)
+ (defun set-code (var val)
+ (list 'setq var val))
+ (= a 1) (= b 1) (= c 1)
+ (eval (set-code 'a '(+ 2 3)))
+ (eval (set-code 'c 42))
+ (= a 5) (= b 1) (= c 42)))
+
+ ; Build code that recursively again and again calls eval. What we want is
+ ; something like:
+ ; (eval '(1+ (eval '(1+ (eval 1)))))
+ (pass-if "recursive eval"
+ (progn (setq depth 10 i depth)
+ (setq code '(eval 0))
+ (while (not (zerop i))
+ (setq code (\` (eval (quote (1+ (\, code))))))
+ (setq i (1- i)))
+ (= (eval code) depth))))
+
+
+; Test handling of variables.
+; ===========================
+
+(with-test-prefix/compile "Variable Setting/Referencing"
+
+ ; TODO: Check for variable-void error
+
+ (pass-if-equal "setq and reference" 6
+ (progn (setq a 1 b 2 c 3)
+ (+ a b c)))
+ (pass-if-equal "setq evaluation order" 1
+ (progn (setq a 0 b 0)
+ (setq a 1 b a)))
+ (pass-if-equal "setq value" 2
+ (progn (setq a 1 b 2)))
+
+ (pass-if "set and symbol-value"
+ (progn (setq myvar 'a)
+ (and (= (set myvar 42) 42)
+ (= a 42)
+ (= (symbol-value myvar) 42))))
+ (pass-if "void variables"
+ (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))))
+
+(with-test-prefix/compile "Let and Let*"
+
+ (pass-if-equal "let without value" nil-value
+ (let (a (b 5)) a))
+ (pass-if-equal "basic let" 0
+ (progn (setq a 0)
+ (let ((a 1)
+ (b a))
+ b)))
+
+ (pass-if "let*"
+ (progn (setq a 0)
+ (and (let* ((a 1)
+ (b a))
+ (= b 1))
+ (let* (a b)
+ (setq a 1 b 2)
+ (and (= a 1) (= b 2)))
+ (= a 0)
+ (not (boundp 'b)))))
+
+ (pass-if "local scope"
+ (progn (setq a 0)
+ (setq b (let (a)
+ (setq a 1)
+ a))
+ (and (= a 0)
+ (= b 1)))))
+
+(with-test-prefix/compile "Lexical Scoping"
+
+ (pass-if "basic let semantics"
+ (and (setq a 1)
+ (lexical-let ((a 2) (b a))
+ (and (= a 2) (= b 1)))
+ (lexical-let* ((a 2) (b a))
+ (and (= a 2) (= b 2) (setq a 42) (= a 42)))
+ (= a 1)))
+
+ (pass-if "lexical scope with lexical-let's"
+ (and (setq a 1)
+ (defun dyna () a)
+ (lexical-let (a)
+ (setq a 2)
+ (and (= a 2) (= (dyna) 1)))
+ (= a 1)
+ (lexical-let* (a)
+ (setq a 2)
+ (and (= a 2) (= (dyna) 1)))
+ (= a 1)))
+
+ (pass-if "lexical scoping vs. symbol-value / set"
+ (and (setq a 1)
+ (lexical-let ((a 2))
+ (and (= a 2)
+ (= (symbol-value 'a) 1)
+ (set 'a 3)
+ (= a 2)
+ (= (symbol-value 'a) 3)))
+ (= a 3)))
+
+ (pass-if "let inside lexical-let"
+ (and (setq a 1 b 1)
+ (defun dynvals () (cons a b))
+ (lexical-let ((a 2))
+ (and (= a 2) (equal (dynvals) '(1 . 1))
+ (let ((a 3) (b a))
+ (and (= a 3) (= b 2)
+ (equal (dynvals) '(1 . 2))))
+ (let* ((a 4) (b a))
+ (and (= a 4) (= b 4)
+ (equal (dynvals) '(1 . 4))))
+ (= a 2)))
+ (= a 1)))
+
+ (pass-if "lambda args inside lexical-let"
+ (and (setq a 1)
+ (defun dyna () a)
+ (lexical-let ((a 2) (b 42))
+ (and (= a 2) (= (dyna) 1)
+ ((lambda (a) (and (= a 3) (= b 42) (= (dyna) 3))) 3)
+ ((lambda () (let ((a 3))
+ (and (= a 3) (= (dyna) 1)))))
+ (= a 2) (= (dyna) 1)))
+ (= a 1)))
+
+ (pass-if "closures"
+ (and (defun make-counter ()
+ (lexical-let ((cnt 0))
+ (lambda ()
+ (setq cnt (1+ cnt)))))
+ (setq c1 (make-counter) c2 (make-counter))
+ (= (funcall c1) 1)
+ (= (funcall c1) 2)
+ (= (funcall c1) 3)
+ (= (funcall c2) 1)
+ (= (funcall c2) 2)
+ (= (funcall c1) 4)
+ (= (funcall c2) 3)))
+
+ (pass-if "always lexical option (all)"
+ (progn (setq a 0)
+ (defun dyna () a)
+ (let ((a 1))
+ (and (= a 1) (= (dyna) 0))))
+ #:opts '(#:always-lexical all))
+ (pass-if "always lexical option (list)"
+ (progn (setq a 0 b 0)
+ (defun dyna () a)
+ (defun dynb () b)
+ (let ((a 1)
+ (b 1))
+ (and (= a 1) (= (dyna) 0)
+ (= b 1) (= (dynb) 1))))
+ #:opts '(#:always-lexical (a)))
+ (pass-if "with-always-lexical"
+ (progn (setq a 0)
+ (defun dyna () a)
+ (with-always-lexical (a)
+ (let ((a 1))
+ (and (= a 1) (= (dyna) 0))))))
+
+ (pass-if "lexical lambda args"
+ (progn (setq a 1 b 1)
+ (defun dyna () a)
+ (defun dynb () b)
+ (with-always-lexical (a c)
+ ((lambda (a b &optional c)
+ (and (= a 3) (= (dyna) 1)
+ (= b 2) (= (dynb) 2)
+ (= c 1)))
+ 3 2 1))))
+
+ ; Check if a lambda without dynamically bound arguments
+ ; is tail-optimized by doing a deep recursion that would otherwise overflow
+ ; the stack.
+ (pass-if "lexical lambda tail-recursion"
+ (with-always-lexical (i)
+ (setq to 1000000)
+ (defun iteration-1 (i)
+ (if (< i to)
+ (iteration-1 (1+ i))))
+ (iteration-1 0)
+ (setq x 0)
+ (defun iteration-2 ()
+ (if (< x to)
+ (setq x (1+ x))
+ (iteration-2)))
+ (iteration-2)
+ t)))
+
+
+(with-test-prefix/compile "defconst and defvar"
+
+ (pass-if-equal "defconst without docstring" 3.141
+ (progn (setq pi 3)
+ (defconst pi 3.141)
+ pi))
+ (pass-if-equal "defconst value" 'pi
+ (defconst pi 3.141 "Pi"))
+
+ (pass-if-equal "defvar without value" 42
+ (progn (setq a 42)
+ (defvar a)
+ a))
+ (pass-if-equal "defvar on already defined variable" 42
+ (progn (setq a 42)
+ (defvar a 1 "Some docstring is also ok")
+ a))
+ (pass-if-equal "defvar on undefined variable" 1
+ (progn (makunbound 'a)
+ (defvar a 1)
+ a))
+ (pass-if-equal "defvar value" 'a
+ (defvar a)))
+
+
+; Functions and lambda expressions.
+; =================================
+
+(with-test-prefix/compile "Lambda Expressions"
+
+ (pass-if-equal "required arguments" 3
+ ((lambda (a b c) c) 1 2 3))
+
+ (pass-if-equal "optional argument" 3
+ ((function (lambda (a &optional b c) c)) 1 2 3))
+ (pass-if-equal "optional missing" nil-value
+ ((lambda (&optional a) a)))
+
+ (pass-if-equal "rest argument" '(3 4 5)
+ ((lambda (a b &rest c) c) 1 2 3 4 5))
+ (pass-if-equal "rest missing" nil-value
+ ((lambda (a b &rest c) c) 1 2)))
+
+(with-test-prefix/compile "Function Definitions"
+
+ (pass-if-equal "defun" 3
+ (progn (defun test (a b) (+ a b))
+ (test 1 2)))
+ (pass-if-equal "defun value" 'test
+ (defun test (a b) (+ a b)))
+
+ (pass-if "fset and symbol-function"
+ (progn (setq myfunc 'x x 5)
+ (and (= (fset myfunc 42) 42)
+ (= (symbol-function myfunc) 42)
+ (= x 5))))
+ (pass-if "void function values"
+ (progn (setq a 1)
+ (defun test (a b) (+ a b))
+ (fmakunbound 'a)
+ (fset 'b 5)
+ (and (fboundp 'b) (fboundp 'test)
+ (not (fboundp 'a))
+ (= a 1))))
+
+ (pass-if "flet and flet*"
+ (progn (defun foobar () 42)
+ (defun test () (foobar))
+ (and (= (test) 42)
+ (flet ((foobar (lambda () 0))
+ (myfoo (symbol-function 'foobar)))
+ (and (= (myfoo) 42)
+ (= (test) 0)))
+ (flet* ((foobar (lambda () 0))
+ (myfoo (symbol-function 'foobar)))
+ (= (myfoo) 0))
+ (flet (foobar)
+ (defun foobar () 0)
+ (= (test) 0))
+ (= (test) 42)))))
+
+(with-test-prefix/compile "Calling Functions"
+
+ (pass-if-equal "recursion" 120
+ (progn (defun factorial (n prod)
+ (if (zerop n)
+ prod
+ (factorial (1- n) (* prod n))))
+ (factorial 5 1)))
+
+ (pass-if "dynamic scoping"
+ (progn (setq a 0)
+ (defun foo ()
+ (setq a (1+ a))
+ a)
+ (defun bar (a)
+ (foo))
+ (and (= 43 (bar 42))
+ (zerop a))))
+
+ (pass-if "funcall and apply argument handling"
+ (and (defun allid (&rest args) args)
+ (setq allid-var (symbol-function 'allid))
+ (equal (funcall allid-var 1 2 3) '(1 2 3))
+ (equal (funcall allid-var) nil)
+ (equal (funcall allid-var 1 2 '(3 4)) '(1 2 (3 4)))
+ (equal (funcall allid-var '()) '(()))
+ (equal (apply allid-var 1 2 '(3 4)) '(1 2 3 4))
+ (equal (apply allid-var '(1 2)) '(1 2))
+ (equal (apply allid-var '()) nil)))
+
+ (pass-if "raw functions with funcall"
+ (and (= (funcall '+ 1 2) 3)
+ (= (funcall (lambda (a b) (+ a b)) 1 2) 3)
+ (= (funcall '(lambda (a b) (+ a b)) 1 2) 3))))
+
+
+; Quoting and Backquotation.
+; ==========================
+
+(with-test-prefix/compile "Quotation"
+
+ (pass-if "quote"
+ (and (equal '42 42) (equal '"abc" "abc")
+ (equal '(1 2 (3 (4) x)) '(1 2 (3 (4) x)))
+ (not (equal '(1 2 (3 4 (x))) '(1 2 3 4 x)))
+ (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))))
+ (pass-if "unquote"
+ (progn (setq a 42 l '(18 12))
+ (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)))
+ '(l 2 (3 18 12) (18 12) 18 12))
+ (equal (\` (1 2 (\,@ empty) 3)) '(1 2 3))))))
+
+
+
+; Macros.
+; =======
+
+(with-test-prefix/compile "Macros"
+
+ (pass-if-equal "defmacro value" 'magic-number
+ (defmacro magic-number () 42))
+
+ (pass-if-equal "macro expansion" 1
+ (progn (defmacro take-first (a b) a)
+ (take-first 1 (/ 1 0)))))
+
+
+; Test the built-ins.
+; ===================
+
+(with-test-prefix/compile "Equivalence Predicates"
+
+ (pass-if "equal"
+ (and (equal 2 2) (not (equal 1 2))
+ (equal "abc" "abc") (not (equal "abc" "ABC"))
+ (equal 'abc 'abc) (not (equal 'abc 'def))
+ (equal '(1 2 (3 4) 5) '(1 2 (3 4) 5))
+ (not (equal '(1 2 3 4 5) '(1 2 (3 4) 5)))))
+
+ (pass-if "eq"
+ (progn (setq some-list '(1 2))
+ (setq some-string "abc")
+ (and (eq 2 2) (not (eq 1 2))
+ (eq 'abc 'abc) (not (eq 'abc 'def))
+ (eq some-string some-string) (not (eq some-string "abc"))
+ (eq some-list some-list) (not (eq some-list '(1 2)))))))
+
+(with-test-prefix/compile "Number Built-Ins"
+
+ (pass-if "floatp"
+ (and (floatp 1.0) (not (floatp 1)) (not (floatp 'a))))
+ (pass-if "integerp"
+ (and (integerp 42) (integerp -2) (not (integerp 1.0))))
+ (pass-if "numberp"
+ (and (numberp 1.0) (numberp -2) (not (numberp 'a))))
+ (pass-if "wholenump"
+ (and (wholenump 0) (not (wholenump -2)) (not (wholenump 1.0))))
+ (pass-if "zerop"
+ (and (zerop 0) (zerop 0.0) (not (zerop 1))))
+
+ (pass-if "comparisons"
+ (and (= 1 1.0) (/= 0 1)
+ (< 1 2) (> 2 1) (>= 1 1) (<= 1 1)
+ (not (< 1 1)) (not (<= 2 1))))
+
+ (pass-if "max and min"
+ (and (= (max -5 2 4.0 1) 4.0) (= (min -5 2 4.0 1) -5)
+ (= (max 1) 1) (= (min 1) 1)))
+ (pass-if "abs"
+ (and (= (abs 1.0) 1.0) (= (abs -5) 5)))
+
+ (pass-if "float"
+ (and (= (float 1) 1) (= (float 5.5) 5.5)
+ (floatp (float 1))))
+
+ (pass-if-equal "basic arithmetic operators" -8.5
+ (+ (1+ 0) (1- 0) (- 5.5) (* 2 -2) (- 2 1)))
+ (pass-if "modulo"
+ (= (% 5 3) 2))
+
+ (pass-if "floating point rounding"
+ (and (= (ffloor 1.7) 1.0) (= (ffloor -1.2) -2.0) (= (ffloor 1.0) 1.0)
+ (= (fceiling 1.2) 2.0) (= (fceiling -1.7) -1.0) (= (fceiling 1.0) 1.0)
+ (= (ftruncate 1.6) 1.0) (= (ftruncate -1.7) -1.0)
+ (= (fround 1.2) 1.0) (= (fround 1.7) 2.0) (= (fround -1.7) -2.0))))
+
+(with-test-prefix/compile "List Built-Ins"
+
+ (pass-if "consp and atomp"
+ (and (consp '(1 2 3)) (consp '(1 2 . 3)) (consp '(a . b))
+ (not (consp '())) (not (consp 1)) (not (consp "abc"))
+ (atomp 'a) (atomp '()) (atomp -1.5) (atomp "abc")
+ (not (atomp '(1 . 2))) (not (atomp '(1)))))
+ (pass-if "listp and nlistp"
+ (and (listp '(1 2 3)) (listp '(1)) (listp '()) (listp '(1 . 2))
+ (not (listp 'a)) (not (listp 42)) (nlistp 42)
+ (not (nlistp '())) (not (nlistp '(1 2 3))) (not (nlistp '(1 . 2)))))
+ (pass-if "null"
+ (and (null '()) (not (null 1)) (not (null '(1 2))) (not (null '(1 . 2)))))
+
+ (pass-if "car and cdr"
+ (and (equal (car '(1 2 3)) 1) (equal (cdr '(1 2 3)) '(2 3))
+ (equal (car '()) nil) (equal (cdr '()) nil)
+ (equal (car '(1 . 2)) 1) (equal (cdr '(1 . 2)) 2)
+ (null (cdr '(1)))))
+ (pass-if "car-safe and cdr-safe"
+ (and (equal (car-safe '(1 2)) 1) (equal (cdr-safe '(1 2)) '(2))
+ (equal (car-safe 5) nil) (equal (cdr-safe 5) nil)))
+
+ (pass-if "pop"
+ (progn (setq mylist '(a b c))
+ (setq value (pop mylist))
+ (and (equal value 'a)
+ (equal mylist '(b c)))))
+ (pass-if-equal "push" '(a b c)
+ (progn (setq mylist '(b c))
+ (push 'a mylist)))
+
+ (pass-if "nth and nthcdr"
+ (and (equal (nth -5 '(1 2 3)) 1) (equal (nth 3 '(1 2 3)) nil)
+ (equal (nth 0 '(1 2 3)) 1) (equal (nth 2 '(1 2 3)) 3)
+ (equal (nthcdr -5 '(1 2 3)) '(1 2 3))
+ (equal (nthcdr 4 '(1 2 3)) nil)
+ (equal (nthcdr 1 '(1 2 3)) '(2 3))
+ (equal (nthcdr 2 '(1 2 3)) '(3))))
+
+ (pass-if "length"
+ (and (= (length '()) 0)
+ (= (length '(1 2 3 4 5)) 5)
+ (= (length '(1 2 (3 4 (5)) 6)) 4)))
+
+ (pass-if "cons, list and make-list"
+ (and (equal (cons 1 2) '(1 . 2)) (equal (cons 1 '(2 3)) '(1 2 3))
+ (equal (cons 1 '()) '(1))
+ (equal (list 'a) '(a)) (equal (list) '()) (equal (list 1 2) '(1 2))
+ (equal (make-list 3 42) '(42 42 42))
+ (equal (make-list 0 1) '())))
+ (pass-if "append"
+ (and (equal (append '(1 2) '(3 4) '(5)) '(1 2 3 4 5))
+ (equal (append '(1 2) 3) '(1 2 . 3))))
+ (pass-if "reverse"
+ (and (equal (reverse '(5 4 3 2 1)) '(1 2 3 4 5))
+ (equal (reverse '()) '())))
+ (pass-if "copy-tree"
+ (progn (setq mylist '(1 2 (3 4)))
+ (and (not (eq mylist (copy-tree mylist)))
+ (equal mylist (copy-tree mylist)))))
+
+ (pass-if "number-sequence"
+ (and (equal (number-sequence 5) '(5))
+ (equal (number-sequence 5 9) '(5 6 7 8 9))
+ (equal (number-sequence 5 9 3) '(5 8))
+ (equal (number-sequence 5 1 -2) '(5 3 1))
+ (equal (number-sequence 5 8 -1) '())
+ (equal (number-sequence 5 1) '())
+ (equal (number-sequence 5 5 0) '(5))))
+
+ (pass-if "setcar and setcdr"
+ (progn (setq pair '(1 . 2))
+ (setq copy pair)
+ (setq a (setcar copy 3))
+ (setq b (setcdr copy 4))
+ (and (= a 3) (= b 4)
+ (equal pair '(3 . 4))))))
diff --git a/test-suite/tests/elisp-reader.test b/test-suite/tests/elisp-reader.test
new file mode 100644
index 000000000..fc7cd1b53
--- /dev/null
+++ b/test-suite/tests/elisp-reader.test
@@ -0,0 +1,185 @@
+;;;; elisp-reader.test --- Test the reader used by the Elisp compiler.
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Daniel Kraft
+;;;;
+;;;; 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
+
+(define-module (test-elisp-reader)
+ :use-module (test-suite lib)
+ :use-module (language elisp lexer)
+ :use-module (language elisp parser))
+
+
+; ==============================================================================
+; Test the lexer.
+
+(define (get-string-lexer str)
+ (call-with-input-string str get-lexer))
+
+(define (lex-all lexer)
+ (let iterate ((result '()))
+ (let ((token (lexer)))
+ (if (eq? token '*eoi*)
+ (reverse result)
+ (iterate (cons token result))))))
+
+(define (lex-string str)
+ (lex-all (get-string-lexer str)))
+
+(with-test-prefix "Lexer"
+
+ (let ((lexer (get-string-lexer "")))
+ (pass-if "end-of-input"
+ (and (eq? (lexer) '*eoi*)
+ (eq? (lexer) '*eoi*)
+ (eq? (lexer) '*eoi*))))
+
+ (pass-if "single character tokens"
+ (equal? (lex-string "()[]'`,,@ . ")
+ '((paren-open . #f) (paren-close . #f)
+ (square-open . #f) (square-close . #f)
+ (quote . #f) (backquote . #f)
+ (unquote . #f) (unquote-splicing . #f) (dot . #f))))
+
+ (pass-if "whitespace and comments"
+ (equal? (lex-string " (\n\t) ; this is a comment\n. ; until eof")
+ '((paren-open . #f) (paren-close . #f) (dot . #f))))
+
+ (pass-if "source properties"
+ (let ((x (car (lex-string "\n\n \n . \n"))))
+ (and (= (source-property x 'line) 4)
+ (= (source-property x 'column) 3))))
+
+ (pass-if "symbols"
+ (equal? (lex-string "foo FOO char-to-string 1+ \\+1
+ \\(*\\ 1\\ 2\\)
+ +-*/_~!@$%^&=:<>{}
+ abc(def)ghi .e5")
+ `((symbol . foo) (symbol . FOO) (symbol . char-to-string)
+ (symbol . 1+) (symbol . ,(string->symbol "+1"))
+ (symbol . ,(string->symbol "(* 1 2)"))
+ (symbol . +-*/_~!@$%^&=:<>{})
+ (symbol . abc) (paren-open . #f) (symbol . def)
+ (paren-close . #f) (symbol . ghi) (symbol . .e5))))
+
+ ; Here we make use of the property that exact/inexact numbers are not equal?
+ ; even when they have the same numeric value!
+ (pass-if "integers"
+ (equal? (lex-string "-1 1 1. +1 01234")
+ '((integer . -1) (integer . 1) (integer . 1) (integer . 1)
+ (integer . 1234))))
+ (pass-if "floats"
+ (equal? (lex-string "1500.0 15e2 15.e2 1.5e3 .15e4 -.345e-2")
+ '((float . 1500.0) (float . 1500.0) (float . 1500.0)
+ (float . 1500.0) (float . 1500.0)
+ (float . -0.00345))))
+
+ ; Check string lexing, this also checks basic character escape sequences
+ ; that are then (hopefully) also correct for character literals.
+ (pass-if "strings"
+ (equal? (lex-string "\"foo\\nbar
+test\\
+\\\"ab\\\"\\\\ ab\\ cd
+\\418\\0415\\u0041\\U0000000A\\Xab\\x0000000000000004fG.\" ")
+ '((string . "foo\nbar
+test\"ab\"\\ abcd
+!8!5A\nXabOG."))))
+ (pass-if "ASCII control characters and meta in strings"
+ (equal? (lex-string "\"\\^?\\C-a\\C-A\\^z\\M-B\\M-\\^@\\M-\\C-a\"")
+ '((string . "\x7F\x01\x01\x1A\xC2\x80\x81"))))
+
+ ; Character literals, taking into account that some escape sequences were
+ ; already checked in the strings.
+ (pass-if "characters"
+ (equal? (lex-string "?A?\\z ? ?\\x21 ?\\^j ?\\\\?\\n?\\\n")
+ `((character . 65) (character . ,(char->integer #\z))
+ (character . 32) (character . ,(char->integer #\!))
+ (character . 10) (character . ,(char->integer #\\))
+ (character . 10) (character . 10))))
+ (pass-if "meta characters"
+ (equal? (map cdr (lex-string "?\\C-[?\\M-\\S-Z?\\^X?\\A-\\s-\\H-\\s"))
+ `(,(+ (expt 2 26) (char->integer #\[))
+ ,(+ (expt 2 27) (expt 2 25) (char->integer #\Z))
+ ,(- (char->integer #\X) (char->integer #\@))
+ ,(+ (expt 2 22) (expt 2 23) (expt 2 24) 32))))
+
+ (pass-if "circular markers"
+ (equal? (lex-string "#0342= #1#")
+ '((circular-def . 342) (circular-ref . 1))))
+
+ (let* ((lex1-string "#1='((1 2) [2 [3]] 5)")
+ (lexer (call-with-input-string (string-append lex1-string " 1 2")
+ get-lexer/1)))
+ (pass-if "lexer/1"
+ (and (equal? (lex-all lexer) (lex-string lex1-string))
+ (eq? (lexer) '*eoi*)
+ (eq? (lexer) '*eoi*)))))
+
+
+; ==============================================================================
+; Test the parser.
+
+(define (parse-str str)
+ (call-with-input-string str read-elisp))
+
+(with-test-prefix "Parser"
+
+ (pass-if "only next expression"
+ (equal? (parse-str "1 2 3") 1))
+
+ (pass-if "source properties"
+ (let* ((list1 (parse-str "\n\n (\n(7) (42))"))
+ (list2 (car list1))
+ (list3 (cadr list1)))
+ (and (= (source-property list1 'line) 3)
+ (= (source-property list1 'column) 4)
+ (= (source-property list2 'line) 4)
+ (= (source-property list2 'column) 1)
+ (= (source-property list3 'line) 4)
+ (= (source-property list3 'column) 6))))
+
+ (pass-if "constants"
+ (and (equal? (parse-str "-12") -12)
+ (equal? (parse-str ".123") 0.123)
+ (equal? (parse-str "foobar") 'foobar)
+ (equal? (parse-str "\"abc\"") "abc")
+ (equal? (parse-str "?A") 65)
+ (equal? (parse-str "?\\C-@") 0)))
+
+ (pass-if "quotation"
+ (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))))))
+
+ (pass-if "lists"
+ (equal? (parse-str "(1 2 (3) () 4 (. 5) (1 2 . (3 4)) (1 . 2) . 42)")
+ '(1 2 (3) () 4 5 (1 2 3 4) (1 . 2) . 42)))
+
+ (pass-if "vectors"
+ (equal? (parse-str "[1 2 [] (3 4) \"abc\" d]")
+ #(1 2 #() (3 4) "abc" d)))
+
+ (pass-if "circular structures"
+ (and (equal? (parse-str "(#1=a #2=b #1# (#1=c #1# #2#) #1#)")
+ '(a b a (c c b) c))
+ (let ((eqpair (parse-str "(#1=\"foobar\" . #1#)")))
+ (eq? (car eqpair) (cdr eqpair)))
+ (let ((circlst (parse-str "#1=(42 #1# #1=5 #1#)")))
+ (and (eq? circlst (cadr circlst))
+ (equal? (cddr circlst) '(5 5))))
+ (let ((circvec (parse-str "#1=[a #1# b]")))
+ (eq? circvec (vector-ref circvec 1))))))
View Lorry Controller Status