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

Merge branch 'bt/elisp'

Browse source 
Conflicts:
	am/guilec
	libguile/_scm.h
	libguile/vm-i-scheme.c
	module/language/elisp/compile-tree-il.scm
	module/language/elisp/runtime.scm
	module/language/elisp/runtime/macros.scm
	module/language/tree-il/compile-glil.scm
	module/language/tree-il/primitives.scm
This commit is contained in:
BT Templeton 2012-03-05 16:52:05 -05:00
commit 5ddd9645c9
23 changed files with 1303 additions and 1619 deletions
Download patch file Download diff file Expand all files Collapse all files

19
am/guilec
View file

@ -1,14 +1,14 @@
# -*- makefile -*-
GOBJECTS = $(SOURCES:%.scm=%.go)
GOBJECTS = $(SOURCES:%.scm=%.go) $(ELISP_SOURCES:%.el=%.go)
GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat
moddir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/$(modpath)
nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES)
nobase_mod_DATA = $(SOURCES) $(ELISP_SOURCES) $(NOCOMP_SOURCES)
ccachedir = $(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache/$(modpath)
nobase_ccache_DATA = $(GOBJECTS)
EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES)
ETAGS_ARGS = $(SOURCES) $(NOCOMP_SOURCES)
EXTRA_DIST = $(SOURCES) $(ELISP_SOURCES) $(NOCOMP_SOURCES)
ETAGS_ARGS = $(SOURCES) $(ELISP_SOURCES) $(NOCOMP_SOURCES)
CLEANFILES = $(GOBJECTS)
@ -24,7 +24,8 @@ AM_V_GUILEC = $(AM_V_GUILEC_$(V))
AM_V_GUILEC_ = $(AM_V_GUILEC_$(AM_DEFAULT_VERBOSITY))
AM_V_GUILEC_0 = @echo " GUILEC" $@;
SUFFIXES = .scm .go
SUFFIXES = .scm .el .go
.scm.go:
$(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
$(top_builddir)/meta/uninstalled-env \
@ -32,3 +33,11 @@ SUFFIXES = .scm .go
-L "$(abs_srcdir)" -L "$(abs_builddir)" \
-L "$(abs_top_srcdir)/guile-readline" \
-o "$@" "$<"
.el.go:
$(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
$(top_builddir)/meta/uninstalled-env \
guild compile --target="$(host)" $(GUILE_WARNINGS) \
-L "$(abs_srcdir)" -L "$(abs_builddir)" \
-L "$(abs_top_srcdir)/guile-readline" \
--from=elisp -o "$@" "$<"

2
libguile/_scm.h
View file

@ -262,7 +262,7 @@ void scm_ia64_longjmp (scm_i_jmp_buf *, int);
/* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 3
#define SCM_OBJCODE_MINOR_VERSION 0
#define SCM_OBJCODE_MINOR_VERSION 1
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \

8
libguile/boolean.c
View file

@ -62,6 +62,14 @@ SCM_DEFINE (scm_not, "not", 1, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_nil_p, "nil?", 1, 0, 0,
(SCM x),
"Return @code{#t} iff @var{x} is nil, else return @code{#f}.")
#define FUNC_NAME s_scm_nil_p
{
return scm_from_bool (scm_is_lisp_false (x));
}
#undef FUNC_NAME
SCM_DEFINE (scm_boolean_p, "boolean?", 1, 0, 0,
(SCM obj),

170
libguile/vm-i-scheme.c
View file

@ -65,7 +65,19 @@ VM_DEFINE_FUNCTION (133, not_nullp, "not-null?", 1)
RETURN (scm_from_bool (!scm_is_null (x)));
}
VM_DEFINE_FUNCTION (134, eqv, "eqv?", 2)
VM_DEFINE_FUNCTION (134, nilp, "nil?", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (scm_is_lisp_false (x)));
}
VM_DEFINE_FUNCTION (135, not_nilp, "not-nil?", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (!scm_is_lisp_false (x)));
}
VM_DEFINE_FUNCTION (136, eqv, "eqv?", 2)
{
ARGS2 (x, y);
if (scm_is_eq (x, y))
@ -76,7 +88,7 @@ VM_DEFINE_FUNCTION (134, eqv, "eqv?", 2)
RETURN (scm_eqv_p (x, y));
}
VM_DEFINE_FUNCTION (135, equal, "equal?", 2)
VM_DEFINE_FUNCTION (137, equal, "equal?", 2)
{
ARGS2 (x, y);
if (scm_is_eq (x, y))
@ -87,25 +99,25 @@ VM_DEFINE_FUNCTION (135, equal, "equal?", 2)
RETURN (scm_equal_p (x, y));
}
VM_DEFINE_FUNCTION (136, pairp, "pair?", 1)
VM_DEFINE_FUNCTION (138, pairp, "pair?", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (scm_is_pair (x)));
}
VM_DEFINE_FUNCTION (137, listp, "list?", 1)
VM_DEFINE_FUNCTION (139, listp, "list?", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (scm_ilength (x) >= 0));
}
VM_DEFINE_FUNCTION (138, symbolp, "symbol?", 1)
VM_DEFINE_FUNCTION (140, symbolp, "symbol?", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (scm_is_symbol (x)));
}
VM_DEFINE_FUNCTION (139, vectorp, "vector?", 1)
VM_DEFINE_FUNCTION (141, vectorp, "vector?", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (SCM_I_IS_VECTOR (x)));
@ -116,7 +128,7 @@ VM_DEFINE_FUNCTION (139, vectorp, "vector?", 1)
* Basic data
*/
VM_DEFINE_FUNCTION (140, cons, "cons", 2)
VM_DEFINE_FUNCTION (142, cons, "cons", 2)
{
ARGS2 (x, y);
CONS (x, x, y);
@ -130,21 +142,21 @@ VM_DEFINE_FUNCTION (140, cons, "cons", 2)
goto vm_error_not_a_pair; \
}
VM_DEFINE_FUNCTION (141, car, "car", 1)
VM_DEFINE_FUNCTION (143, car, "car", 1)
{
ARGS1 (x);
VM_VALIDATE_CONS (x, "car");
RETURN (SCM_CAR (x));
}
VM_DEFINE_FUNCTION (142, cdr, "cdr", 1)
VM_DEFINE_FUNCTION (144, cdr, "cdr", 1)
{
ARGS1 (x);
VM_VALIDATE_CONS (x, "cdr");
RETURN (SCM_CDR (x));
}
VM_DEFINE_INSTRUCTION (143, set_car, "set-car!", 0, 2, 0)
VM_DEFINE_INSTRUCTION (145, set_car, "set-car!", 0, 2, 0)
{
SCM x, y;
POP2 (y, x);
@ -153,7 +165,7 @@ VM_DEFINE_INSTRUCTION (143, set_car, "set-car!", 0, 2, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (144, set_cdr, "set-cdr!", 0, 2, 0)
VM_DEFINE_INSTRUCTION (146, set_cdr, "set-cdr!", 0, 2, 0)
{
SCM x, y;
POP2 (y, x);
@ -178,27 +190,27 @@ VM_DEFINE_INSTRUCTION (144, set_cdr, "set-cdr!", 0, 2, 0)
RETURN (srel (x, y)); \
}
VM_DEFINE_FUNCTION (145, ee, "ee?", 2)
VM_DEFINE_FUNCTION (147, ee, "ee?", 2)
{
REL (==, scm_num_eq_p);
}
VM_DEFINE_FUNCTION (146, lt, "lt?", 2)
VM_DEFINE_FUNCTION (148, lt, "lt?", 2)
{
REL (<, scm_less_p);
}
VM_DEFINE_FUNCTION (147, le, "le?", 2)
VM_DEFINE_FUNCTION (149, le, "le?", 2)
{
REL (<=, scm_leq_p);
}
VM_DEFINE_FUNCTION (148, gt, "gt?", 2)
VM_DEFINE_FUNCTION (150, gt, "gt?", 2)
{
REL (>, scm_gr_p);
}
VM_DEFINE_FUNCTION (149, ge, "ge?", 2)
VM_DEFINE_FUNCTION (151, ge, "ge?", 2)
{
REL (>=, scm_geq_p);
}
@ -280,7 +292,7 @@ VM_DEFINE_FUNCTION (149, ge, "ge?", 2)
#endif
VM_DEFINE_FUNCTION (150, add, "add", 2)
VM_DEFINE_FUNCTION (152, add, "add", 2)
{
#ifndef ASM_ADD
FUNC2 (+, scm_sum);
@ -292,7 +304,7 @@ VM_DEFINE_FUNCTION (150, add, "add", 2)
#endif
}
VM_DEFINE_FUNCTION (151, add1, "add1", 1)
VM_DEFINE_FUNCTION (153, add1, "add1", 1)
{
ARGS1 (x);
@ -314,7 +326,7 @@ VM_DEFINE_FUNCTION (151, add1, "add1", 1)
RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
}
VM_DEFINE_FUNCTION (152, sub, "sub", 2)
VM_DEFINE_FUNCTION (154, sub, "sub", 2)
{
#ifndef ASM_SUB
FUNC2 (-, scm_difference);
@ -326,7 +338,7 @@ VM_DEFINE_FUNCTION (152, sub, "sub", 2)
#endif
}
VM_DEFINE_FUNCTION (153, sub1, "sub1", 1)
VM_DEFINE_FUNCTION (155, sub1, "sub1", 1)
{
ARGS1 (x);
@ -351,42 +363,42 @@ VM_DEFINE_FUNCTION (153, sub1, "sub1", 1)
# undef ASM_ADD
# undef ASM_SUB
VM_DEFINE_FUNCTION (154, mul, "mul", 2)
VM_DEFINE_FUNCTION (156, mul, "mul", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_product (x, y));
}
VM_DEFINE_FUNCTION (155, div, "div", 2)
VM_DEFINE_FUNCTION (157, div, "div", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_divide (x, y));
}
VM_DEFINE_FUNCTION (156, quo, "quo", 2)
VM_DEFINE_FUNCTION (158, quo, "quo", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_quotient (x, y));
}
VM_DEFINE_FUNCTION (157, rem, "rem", 2)
VM_DEFINE_FUNCTION (159, rem, "rem", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_remainder (x, y));
}
VM_DEFINE_FUNCTION (158, mod, "mod", 2)
VM_DEFINE_FUNCTION (160, mod, "mod", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_modulo (x, y));
}
VM_DEFINE_FUNCTION (159, ash, "ash", 2)
VM_DEFINE_FUNCTION (161, ash, "ash", 2)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@ -415,7 +427,7 @@ VM_DEFINE_FUNCTION (159, ash, "ash", 2)
RETURN (scm_ash (x, y));
}
VM_DEFINE_FUNCTION (160, logand, "logand", 2)
VM_DEFINE_FUNCTION (162, logand, "logand", 2)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@ -424,7 +436,7 @@ VM_DEFINE_FUNCTION (160, logand, "logand", 2)
RETURN (scm_logand (x, y));
}
VM_DEFINE_FUNCTION (161, logior, "logior", 2)
VM_DEFINE_FUNCTION (163, logior, "logior", 2)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@ -433,7 +445,7 @@ VM_DEFINE_FUNCTION (161, logior, "logior", 2)
RETURN (scm_logior (x, y));
}
VM_DEFINE_FUNCTION (162, logxor, "logxor", 2)
VM_DEFINE_FUNCTION (164, logxor, "logxor", 2)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@ -447,7 +459,7 @@ VM_DEFINE_FUNCTION (162, logxor, "logxor", 2)
* Strings
*/
VM_DEFINE_FUNCTION (163, string_length, "string-length", 1)
VM_DEFINE_FUNCTION (165, string_length, "string-length", 1)
{
ARGS1 (str);
if (SCM_LIKELY (scm_is_string (str)))
@ -459,7 +471,7 @@ VM_DEFINE_FUNCTION (163, string_length, "string-length", 1)
}
}
VM_DEFINE_FUNCTION (164, string_ref, "string-ref", 2)
VM_DEFINE_FUNCTION (166, string_ref, "string-ref", 2)
{
scm_t_signed_bits i = 0;
ARGS2 (str, idx);
@ -482,7 +494,7 @@ VM_DEFINE_FUNCTION (164, string_ref, "string-ref", 2)
* Vectors and arrays
*/
VM_DEFINE_FUNCTION (165, vector_length, "vector-length", 1)
VM_DEFINE_FUNCTION (167, vector_length, "vector-length", 1)
{
ARGS1 (vect);
if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
@ -494,7 +506,7 @@ VM_DEFINE_FUNCTION (165, vector_length, "vector-length", 1)
}
}
VM_DEFINE_FUNCTION (166, vector_ref, "vector-ref", 2)
VM_DEFINE_FUNCTION (168, vector_ref, "vector-ref", 2)
{
scm_t_signed_bits i = 0;
ARGS2 (vect, idx);
@ -510,7 +522,7 @@ VM_DEFINE_FUNCTION (166, vector_ref, "vector-ref", 2)
}
}
VM_DEFINE_INSTRUCTION (167, vector_set, "vector-set", 0, 3, 0)
VM_DEFINE_INSTRUCTION (169, vector_set, "vector-set", 0, 3, 0)
{
scm_t_signed_bits i = 0;
SCM vect, idx, val;
@ -528,7 +540,7 @@ VM_DEFINE_INSTRUCTION (167, vector_set, "vector-set", 0, 3, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (168, make_array, "make-array", 3, -1, 1)
VM_DEFINE_INSTRUCTION (170, make_array, "make-array", 3, -1, 1)
{
scm_t_uint32 len;
SCM shape, ret;
@ -557,20 +569,20 @@ VM_DEFINE_INSTRUCTION (168, make_array, "make-array", 3, -1, 1)
goto vm_error_not_a_struct; \
}
VM_DEFINE_FUNCTION (169, struct_p, "struct?", 1)
VM_DEFINE_FUNCTION (171, struct_p, "struct?", 1)
{
ARGS1 (obj);
RETURN (scm_from_bool (SCM_STRUCTP (obj)));
}
VM_DEFINE_FUNCTION (170, struct_vtable, "struct-vtable", 1)
VM_DEFINE_FUNCTION (172, struct_vtable, "struct-vtable", 1)
{
ARGS1 (obj);
VM_VALIDATE_STRUCT (obj, "struct_vtable");
RETURN (SCM_STRUCT_VTABLE (obj));
}
VM_DEFINE_INSTRUCTION (171, make_struct, "make-struct", 2, -1, 1)
VM_DEFINE_INSTRUCTION (173, make_struct, "make-struct", 2, -1, 1)
{
unsigned h = FETCH ();
unsigned l = FETCH ();
@ -603,7 +615,7 @@ VM_DEFINE_INSTRUCTION (171, make_struct, "make-struct", 2, -1, 1)
NEXT;
}
VM_DEFINE_FUNCTION (172, struct_ref, "struct-ref", 2)
VM_DEFINE_FUNCTION (174, struct_ref, "struct-ref", 2)
{
ARGS2 (obj, pos);
@ -633,7 +645,7 @@ VM_DEFINE_FUNCTION (172, struct_ref, "struct-ref", 2)
RETURN (scm_struct_ref (obj, pos));
}
VM_DEFINE_FUNCTION (173, struct_set, "struct-set", 3)
VM_DEFINE_FUNCTION (175, struct_set, "struct-set", 3)
{
ARGS3 (obj, pos, val);
@ -667,7 +679,7 @@ VM_DEFINE_FUNCTION (173, struct_set, "struct-set", 3)
/*
* GOOPS support
*/
VM_DEFINE_FUNCTION (174, class_of, "class-of", 1)
VM_DEFINE_FUNCTION (176, class_of, "class-of", 1)
{
ARGS1 (obj);
if (SCM_INSTANCEP (obj))
@ -677,7 +689,7 @@ VM_DEFINE_FUNCTION (174, class_of, "class-of", 1)
}
/* FIXME: No checking whatsoever. */
VM_DEFINE_FUNCTION (175, slot_ref, "slot-ref", 2)
VM_DEFINE_FUNCTION (177, slot_ref, "slot-ref", 2)
{
size_t slot;
ARGS2 (instance, idx);
@ -686,7 +698,7 @@ VM_DEFINE_FUNCTION (175, slot_ref, "slot-ref", 2)
}
/* FIXME: No checking whatsoever. */
VM_DEFINE_INSTRUCTION (176, slot_set, "slot-set", 0, 3, 0)
VM_DEFINE_INSTRUCTION (178, slot_set, "slot-set", 0, 3, 0)
{
SCM instance, idx, val;
size_t slot;
@ -729,21 +741,21 @@ VM_DEFINE_INSTRUCTION (176, slot_set, "slot-set", 0, 3, 0)
#define ALIGNED_P(ptr, type) \
((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
VM_DEFINE_FUNCTION (177, bv_u16_ref, "bv-u16-ref", 3)
VM_DEFINE_FUNCTION (179, bv_u16_ref, "bv-u16-ref", 3)
BV_REF_WITH_ENDIANNESS (u16, u16)
VM_DEFINE_FUNCTION (178, bv_s16_ref, "bv-s16-ref", 3)
VM_DEFINE_FUNCTION (180, bv_s16_ref, "bv-s16-ref", 3)
BV_REF_WITH_ENDIANNESS (s16, s16)
VM_DEFINE_FUNCTION (179, bv_u32_ref, "bv-u32-ref", 3)
VM_DEFINE_FUNCTION (181, bv_u32_ref, "bv-u32-ref", 3)
BV_REF_WITH_ENDIANNESS (u32, u32)
VM_DEFINE_FUNCTION (180, bv_s32_ref, "bv-s32-ref", 3)
VM_DEFINE_FUNCTION (182, bv_s32_ref, "bv-s32-ref", 3)
BV_REF_WITH_ENDIANNESS (s32, s32)
VM_DEFINE_FUNCTION (181, bv_u64_ref, "bv-u64-ref", 3)
VM_DEFINE_FUNCTION (183, bv_u64_ref, "bv-u64-ref", 3)
BV_REF_WITH_ENDIANNESS (u64, u64)
VM_DEFINE_FUNCTION (182, bv_s64_ref, "bv-s64-ref", 3)
VM_DEFINE_FUNCTION (184, bv_s64_ref, "bv-s64-ref", 3)
BV_REF_WITH_ENDIANNESS (s64, s64)
VM_DEFINE_FUNCTION (183, bv_f32_ref, "bv-f32-ref", 3)
VM_DEFINE_FUNCTION (185, bv_f32_ref, "bv-f32-ref", 3)
BV_REF_WITH_ENDIANNESS (f32, ieee_single)
VM_DEFINE_FUNCTION (184, bv_f64_ref, "bv-f64-ref", 3)
VM_DEFINE_FUNCTION (186, bv_f64_ref, "bv-f64-ref", 3)
BV_REF_WITH_ENDIANNESS (f64, ieee_double)
#undef BV_REF_WITH_ENDIANNESS
@ -821,33 +833,33 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double)
RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
}
VM_DEFINE_FUNCTION (185, bv_u8_ref, "bv-u8-ref", 2)
VM_DEFINE_FUNCTION (187, bv_u8_ref, "bv-u8-ref", 2)
BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
VM_DEFINE_FUNCTION (186, bv_s8_ref, "bv-s8-ref", 2)
VM_DEFINE_FUNCTION (188, bv_s8_ref, "bv-s8-ref", 2)
BV_FIXABLE_INT_REF (s8, s8, int8, 1)
VM_DEFINE_FUNCTION (187, bv_u16_native_ref, "bv-u16-native-ref", 2)
VM_DEFINE_FUNCTION (189, bv_u16_native_ref, "bv-u16-native-ref", 2)
BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
VM_DEFINE_FUNCTION (188, bv_s16_native_ref, "bv-s16-native-ref", 2)
VM_DEFINE_FUNCTION (190, bv_s16_native_ref, "bv-s16-native-ref", 2)
BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
VM_DEFINE_FUNCTION (189, bv_u32_native_ref, "bv-u32-native-ref", 2)
VM_DEFINE_FUNCTION (191, bv_u32_native_ref, "bv-u32-native-ref", 2)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4)
#else
BV_INT_REF (u32, uint32, 4)
#endif
VM_DEFINE_FUNCTION (190, bv_s32_native_ref, "bv-s32-native-ref", 2)
VM_DEFINE_FUNCTION (192, bv_s32_native_ref, "bv-s32-native-ref", 2)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (s32, s32_native, int32, 4)
#else
BV_INT_REF (s32, int32, 4)
#endif
VM_DEFINE_FUNCTION (191, bv_u64_native_ref, "bv-u64-native-ref", 2)
VM_DEFINE_FUNCTION (193, bv_u64_native_ref, "bv-u64-native-ref", 2)
BV_INT_REF (u64, uint64, 8)
VM_DEFINE_FUNCTION (192, bv_s64_native_ref, "bv-s64-native-ref", 2)
VM_DEFINE_FUNCTION (194, bv_s64_native_ref, "bv-s64-native-ref", 2)
BV_INT_REF (s64, int64, 8)
VM_DEFINE_FUNCTION (193, bv_f32_native_ref, "bv-f32-native-ref", 2)
VM_DEFINE_FUNCTION (195, bv_f32_native_ref, "bv-f32-native-ref", 2)
BV_FLOAT_REF (f32, ieee_single, float, 4)
VM_DEFINE_FUNCTION (194, bv_f64_native_ref, "bv-f64-native-ref", 2)
VM_DEFINE_FUNCTION (196, bv_f64_native_ref, "bv-f64-native-ref", 2)
BV_FLOAT_REF (f64, ieee_double, double, 8)
#undef BV_FIXABLE_INT_REF
@ -870,21 +882,21 @@ BV_FLOAT_REF (f64, ieee_double, double, 8)
} \
}
VM_DEFINE_INSTRUCTION (195, bv_u16_set, "bv-u16-set", 0, 4, 0)
VM_DEFINE_INSTRUCTION (197, bv_u16_set, "bv-u16-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u16, u16)
VM_DEFINE_INSTRUCTION (196, bv_s16_set, "bv-s16-set", 0, 4, 0)
VM_DEFINE_INSTRUCTION (198, bv_s16_set, "bv-s16-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s16, s16)
VM_DEFINE_INSTRUCTION (197, bv_u32_set, "bv-u32-set", 0, 4, 0)
VM_DEFINE_INSTRUCTION (199, bv_u32_set, "bv-u32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u32, u32)
VM_DEFINE_INSTRUCTION (198, bv_s32_set, "bv-s32-set", 0, 4, 0)
VM_DEFINE_INSTRUCTION (200, bv_s32_set, "bv-s32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s32, s32)
VM_DEFINE_INSTRUCTION (199, bv_u64_set, "bv-u64-set", 0, 4, 0)
VM_DEFINE_INSTRUCTION (201, bv_u64_set, "bv-u64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u64, u64)
VM_DEFINE_INSTRUCTION (200, bv_s64_set, "bv-s64-set", 0, 4, 0)
VM_DEFINE_INSTRUCTION (202, bv_s64_set, "bv-s64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s64, s64)
VM_DEFINE_INSTRUCTION (201, bv_f32_set, "bv-f32-set", 0, 4, 0)
VM_DEFINE_INSTRUCTION (203, bv_f32_set, "bv-f32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (f32, ieee_single)
VM_DEFINE_INSTRUCTION (202, bv_f64_set, "bv-f64-set", 0, 4, 0)
VM_DEFINE_INSTRUCTION (204, bv_f64_set, "bv-f64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (f64, ieee_double)
#undef BV_SET_WITH_ENDIANNESS
@ -964,33 +976,33 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
NEXT; \
}
VM_DEFINE_INSTRUCTION (203, bv_u8_set, "bv-u8-set", 0, 3, 0)
VM_DEFINE_INSTRUCTION (205, bv_u8_set, "bv-u8-set", 0, 3, 0)
BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
VM_DEFINE_INSTRUCTION (204, bv_s8_set, "bv-s8-set", 0, 3, 0)
VM_DEFINE_INSTRUCTION (206, bv_s8_set, "bv-s8-set", 0, 3, 0)
BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
VM_DEFINE_INSTRUCTION (205, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
VM_DEFINE_INSTRUCTION (207, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
VM_DEFINE_INSTRUCTION (206, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
VM_DEFINE_INSTRUCTION (208, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2)
VM_DEFINE_INSTRUCTION (207, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
VM_DEFINE_INSTRUCTION (209, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4)
#else
BV_INT_SET (u32, uint32, 4)
#endif
VM_DEFINE_INSTRUCTION (208, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
VM_DEFINE_INSTRUCTION (210, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4)
#else
BV_INT_SET (s32, int32, 4)
#endif
VM_DEFINE_INSTRUCTION (209, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
VM_DEFINE_INSTRUCTION (211, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
BV_INT_SET (u64, uint64, 8)
VM_DEFINE_INSTRUCTION (210, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
VM_DEFINE_INSTRUCTION (212, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
BV_INT_SET (s64, int64, 8)
VM_DEFINE_INSTRUCTION (211, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
VM_DEFINE_INSTRUCTION (213, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
BV_FLOAT_SET (f32, ieee_single, float, 4)
VM_DEFINE_INSTRUCTION (212, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
VM_DEFINE_INSTRUCTION (214, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
BV_FLOAT_SET (f64, ieee_double, double, 8)
#undef BV_FIXABLE_INT_SET

120
libguile/vm-i-system.c
View file

@ -538,12 +538,25 @@ VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0)
BR (!scm_is_null (x));
}
VM_DEFINE_INSTRUCTION (41, br_if_nil, "br-if-nil", 3, 0, 0)
{
SCM x;
POP (x);
BR (scm_is_lisp_false (x));
}
VM_DEFINE_INSTRUCTION (42, br_if_not_nil, "br-if-not-nil", 3, 0, 0)
{
SCM x;
POP (x);
BR (!scm_is_lisp_false (x));
}
/*
* Subprogram call
*/
VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0)
VM_DEFINE_INSTRUCTION (43, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0)
{
scm_t_ptrdiff n;
scm_t_int32 offset;
@ -555,7 +568,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 (44, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0)
{
scm_t_ptrdiff n;
scm_t_int32 offset;
@ -567,7 +580,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 (45, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
{
scm_t_ptrdiff n;
scm_t_int32 offset;
@ -580,7 +593,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 (46, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
@ -590,7 +603,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 (47, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
@ -600,7 +613,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 (48, bind_optionals, "bind-optionals", 2, -1, -1)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
@ -610,7 +623,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 (49, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1)
{
SCM *walk;
scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
@ -653,7 +666,7 @@ VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6,
#define F_ALLOW_OTHER_KEYS 1
#define F_REST 2
VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0)
VM_DEFINE_INSTRUCTION (50, bind_kwargs, "bind-kwargs", 5, 0, 0)
{
scm_t_uint16 idx;
scm_t_ptrdiff nkw;
@ -706,7 +719,7 @@ VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0)
#undef F_REST
VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1)
VM_DEFINE_INSTRUCTION (51, push_rest, "push-rest", 2, -1, -1)
{
scm_t_ptrdiff n;
SCM rest = SCM_EOL;
@ -719,7 +732,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 (52, bind_rest, "bind-rest", 4, -1, -1)
{
scm_t_ptrdiff n;
scm_t_uint32 i;
@ -735,7 +748,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 (53, reserve_locals, "reserve-locals", 2, -1, -1)
{
SCM *old_sp;
scm_t_int32 n;
@ -756,7 +769,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 (54, 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 */
@ -771,7 +784,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 (55, call, "call", 1, -1, 1)
{
nargs = FETCH ();
@ -819,7 +832,7 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1)
VM_DEFINE_INSTRUCTION (56, tail_call, "tail-call", 1, -1, 1)
{
nargs = FETCH ();
@ -870,7 +883,7 @@ VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1)
}
}
VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1)
VM_DEFINE_INSTRUCTION (57, subr_call, "subr-call", 1, -1, -1)
{
SCM pointer, ret;
SCM (*subr)();
@ -939,7 +952,7 @@ VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1)
}
}
VM_DEFINE_INSTRUCTION (56, smob_call, "smob-call", 1, -1, -1)
VM_DEFINE_INSTRUCTION (58, smob_call, "smob-call", 1, -1, -1)
{
SCM smob, ret;
SCM (*subr)();
@ -986,7 +999,7 @@ VM_DEFINE_INSTRUCTION (56, smob_call, "smob-call", 1, -1, -1)
}
}
VM_DEFINE_INSTRUCTION (57, foreign_call, "foreign-call", 1, -1, -1)
VM_DEFINE_INSTRUCTION (59, foreign_call, "foreign-call", 1, -1, -1)
{
SCM foreign, ret;
nargs = FETCH ();
@ -1014,7 +1027,7 @@ VM_DEFINE_INSTRUCTION (57, foreign_call, "foreign-call", 1, -1, -1)
}
}
VM_DEFINE_INSTRUCTION (58, continuation_call, "continuation-call", 0, -1, 0)
VM_DEFINE_INSTRUCTION (60, continuation_call, "continuation-call", 0, -1, 0)
{
SCM contregs;
POP (contregs);
@ -1030,7 +1043,7 @@ VM_DEFINE_INSTRUCTION (58, continuation_call, "continuation-call", 0, -1, 0)
abort ();
}
VM_DEFINE_INSTRUCTION (59, partial_cont_call, "partial-cont-call", 0, -1, 0)
VM_DEFINE_INSTRUCTION (61, partial_cont_call, "partial-cont-call", 0, -1, 0)
{
SCM vmcont;
scm_t_ptrdiff reloc;
@ -1081,7 +1094,7 @@ VM_DEFINE_INSTRUCTION (59, partial_cont_call, "partial-cont-call", 0, -1, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (60, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
VM_DEFINE_INSTRUCTION (62, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@ -1090,7 +1103,7 @@ VM_DEFINE_INSTRUCTION (60, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
goto vm_tail_call;
}
VM_DEFINE_INSTRUCTION (61, call_nargs, "call/nargs", 0, 0, 1)
VM_DEFINE_INSTRUCTION (63, call_nargs, "call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@ -1099,7 +1112,7 @@ VM_DEFINE_INSTRUCTION (61, call_nargs, "call/nargs", 0, 0, 1)
goto vm_call;
}
VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1)
VM_DEFINE_INSTRUCTION (64, mv_call, "mv-call", 4, -1, 1)
{
scm_t_int32 offset;
scm_t_uint8 *mvra;
@ -1152,7 +1165,7 @@ VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (63, apply, "apply", 1, -1, 1)
VM_DEFINE_INSTRUCTION (65, apply, "apply", 1, -1, 1)
{
int len;
SCM ls;
@ -1174,7 +1187,7 @@ VM_DEFINE_INSTRUCTION (63, apply, "apply", 1, -1, 1)
goto vm_call;
}
VM_DEFINE_INSTRUCTION (64, tail_apply, "tail-apply", 1, -1, 1)
VM_DEFINE_INSTRUCTION (66, tail_apply, "tail-apply", 1, -1, 1)
{
int len;
SCM ls;
@ -1196,7 +1209,7 @@ VM_DEFINE_INSTRUCTION (64, tail_apply, "tail-apply", 1, -1, 1)
goto vm_tail_call;
}
VM_DEFINE_INSTRUCTION (65, call_cc, "call/cc", 0, 1, 1)
VM_DEFINE_INSTRUCTION (67, call_cc, "call/cc", 0, 1, 1)
{
int first;
SCM proc, vm_cont, cont;
@ -1234,7 +1247,7 @@ VM_DEFINE_INSTRUCTION (65, call_cc, "call/cc", 0, 1, 1)
}
}
VM_DEFINE_INSTRUCTION (66, tail_call_cc, "tail-call/cc", 0, 1, 1)
VM_DEFINE_INSTRUCTION (68, tail_call_cc, "tail-call/cc", 0, 1, 1)
{
int first;
SCM proc, vm_cont, cont;
@ -1277,7 +1290,7 @@ VM_DEFINE_INSTRUCTION (66, tail_call_cc, "tail-call/cc", 0, 1, 1)
}
}
VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1)
VM_DEFINE_INSTRUCTION (69, return, "return", 0, 1, 1)
{
vm_return:
POP_CONTINUATION_HOOK (1);
@ -1313,7 +1326,7 @@ VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1)
VM_DEFINE_INSTRUCTION (70, 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. */
@ -1369,7 +1382,7 @@ VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1)
NEXT;
}
VM_DEFINE_INSTRUCTION (69, return_values_star, "return/values*", 1, -1, -1)
VM_DEFINE_INSTRUCTION (71, return_values_star, "return/values*", 1, -1, -1)
{
SCM l;
@ -1392,7 +1405,7 @@ VM_DEFINE_INSTRUCTION (69, return_values_star, "return/values*", 1, -1, -1)
goto vm_return_values;
}
VM_DEFINE_INSTRUCTION (70, return_nvalues, "return/nvalues", 0, 1, -1)
VM_DEFINE_INSTRUCTION (72, return_nvalues, "return/nvalues", 0, 1, -1)
{
SCM n;
POP (n);
@ -1401,7 +1414,7 @@ VM_DEFINE_INSTRUCTION (70, return_nvalues, "return/nvalues", 0, 1, -1)
goto vm_return_values;
}
VM_DEFINE_INSTRUCTION (71, truncate_values, "truncate-values", 2, -1, -1)
VM_DEFINE_INSTRUCTION (73, truncate_values, "truncate-values", 2, -1, -1)
{
SCM x;
int nbinds, rest;
@ -1424,7 +1437,7 @@ VM_DEFINE_INSTRUCTION (71, truncate_values, "truncate-values", 2, -1, -1)
NEXT;
}
VM_DEFINE_INSTRUCTION (72, box, "box", 1, 1, 0)
VM_DEFINE_INSTRUCTION (74, box, "box", 1, 1, 0)
{
SCM val;
POP (val);
@ -1438,7 +1451,7 @@ VM_DEFINE_INSTRUCTION (72, box, "box", 1, 1, 0)
(set! a (lambda () (b ...)))
...)
*/
VM_DEFINE_INSTRUCTION (73, empty_box, "empty-box", 1, 0, 0)
VM_DEFINE_INSTRUCTION (75, empty_box, "empty-box", 1, 0, 0)
{
SYNC_BEFORE_GC ();
LOCAL_SET (FETCH (),
@ -1446,7 +1459,7 @@ VM_DEFINE_INSTRUCTION (73, empty_box, "empty-box", 1, 0, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (74, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
VM_DEFINE_INSTRUCTION (76, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
{
SCM v = LOCAL_REF (FETCH ());
ASSERT_BOUND_VARIABLE (v);
@ -1454,7 +1467,7 @@ VM_DEFINE_INSTRUCTION (74, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (75, local_boxed_set, "local-boxed-set", 1, 1, 0)
VM_DEFINE_INSTRUCTION (77, local_boxed_set, "local-boxed-set", 1, 1, 0)
{
SCM v, val;
v = LOCAL_REF (FETCH ());
@ -1464,7 +1477,7 @@ VM_DEFINE_INSTRUCTION (75, local_boxed_set, "local-boxed-set", 1, 1, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (76, free_ref, "free-ref", 1, 0, 1)
VM_DEFINE_INSTRUCTION (78, free_ref, "free-ref", 1, 0, 1)
{
scm_t_uint8 idx = FETCH ();
@ -1475,7 +1488,7 @@ VM_DEFINE_INSTRUCTION (76, free_ref, "free-ref", 1, 0, 1)
/* no free-set -- if a var is assigned, it should be in a box */
VM_DEFINE_INSTRUCTION (77, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
VM_DEFINE_INSTRUCTION (79, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
{
SCM v;
scm_t_uint8 idx = FETCH ();
@ -1486,7 +1499,7 @@ VM_DEFINE_INSTRUCTION (77, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (78, free_boxed_set, "free-boxed-set", 1, 1, 0)
VM_DEFINE_INSTRUCTION (80, free_boxed_set, "free-boxed-set", 1, 1, 0)
{
SCM v, val;
scm_t_uint8 idx = FETCH ();
@ -1498,7 +1511,7 @@ VM_DEFINE_INSTRUCTION (78, free_boxed_set, "free-boxed-set", 1, 1, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (79, make_closure, "make-closure", 2, -1, 1)
VM_DEFINE_INSTRUCTION (81, make_closure, "make-closure", 2, -1, 1)
{
size_t n, len;
SCM closure;
@ -1517,7 +1530,7 @@ VM_DEFINE_INSTRUCTION (79, make_closure, "make-closure", 2, -1, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (80, make_variable, "make-variable", 0, 0, 1)
VM_DEFINE_INSTRUCTION (82, make_variable, "make-variable", 0, 0, 1)
{
SYNC_BEFORE_GC ();
/* fixme underflow */
@ -1525,7 +1538,7 @@ VM_DEFINE_INSTRUCTION (80, make_variable, "make-variable", 0, 0, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (81, fix_closure, "fix-closure", 2, -1, 0)
VM_DEFINE_INSTRUCTION (83, fix_closure, "fix-closure", 2, -1, 0)
{
SCM x;
unsigned int i = FETCH ();
@ -1542,7 +1555,7 @@ VM_DEFINE_INSTRUCTION (81, fix_closure, "fix-closure", 2, -1, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2)
VM_DEFINE_INSTRUCTION (84, define, "define", 0, 0, 2)
{
SCM sym, val;
POP2 (sym, val);
@ -1553,7 +1566,7 @@ VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2)
NEXT;
}
VM_DEFINE_INSTRUCTION (83, make_keyword, "make-keyword", 0, 1, 1)
VM_DEFINE_INSTRUCTION (85, make_keyword, "make-keyword", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
@ -1561,7 +1574,7 @@ VM_DEFINE_INSTRUCTION (83, make_keyword, "make-keyword", 0, 1, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (84, make_symbol, "make-symbol", 0, 1, 1)
VM_DEFINE_INSTRUCTION (86, make_symbol, "make-symbol", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
@ -1569,7 +1582,7 @@ VM_DEFINE_INSTRUCTION (84, make_symbol, "make-symbol", 0, 1, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0)
VM_DEFINE_INSTRUCTION (87, prompt, "prompt", 4, 2, 0)
{
scm_t_int32 offset;
scm_t_uint8 escape_only_p;
@ -1609,7 +1622,7 @@ VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0)
VM_DEFINE_INSTRUCTION (88, wind, "wind", 0, 2, 0)
{
SCM wind, unwind;
POP2 (unwind, wind);
@ -1623,7 +1636,7 @@ VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1)
VM_DEFINE_INSTRUCTION (89, abort, "abort", 1, -1, -1)
{
unsigned n = FETCH ();
SYNC_REGISTER ();
@ -1634,7 +1647,7 @@ VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1)
abort ();
}
VM_DEFINE_INSTRUCTION (88, unwind, "unwind", 0, 0, 0)
VM_DEFINE_INSTRUCTION (90, unwind, "unwind", 0, 0, 0)
{
/* A normal exit from the dynamic extent of an expression. Pop the top entry
off of the dynamic stack. */
@ -1642,7 +1655,7 @@ VM_DEFINE_INSTRUCTION (88, unwind, "unwind", 0, 0, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0)
VM_DEFINE_INSTRUCTION (91, wind_fluids, "wind-fluids", 1, -1, 0)
{
unsigned n = FETCH ();
@ -1655,7 +1668,7 @@ VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0)
VM_DEFINE_INSTRUCTION (92, unwind_fluids, "unwind-fluids", 0, 0, 0)
{
/* This function must not allocate. */
scm_dynstack_unwind_fluids (&current_thread->dynstack,
@ -1663,7 +1676,7 @@ VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1)
VM_DEFINE_INSTRUCTION (93, fluid_ref, "fluid-ref", 0, 1, 1)
{
size_t num;
SCM fluids;
@ -1693,7 +1706,7 @@ VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2, 0)
VM_DEFINE_INSTRUCTION (94, fluid_set, "fluid-set", 0, 2, 0)
{
size_t num;
SCM val, fluid, fluids;
@ -1713,7 +1726,7 @@ VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0)
VM_DEFINE_INSTRUCTION (95, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0)
{
scm_t_ptrdiff n;
SCM *old_sp;
@ -1733,7 +1746,6 @@ VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1,
NEXT;
}
/*
(defun renumber-ops ()
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"

6
module/Makefile.am
View file

@ -135,6 +135,7 @@ ECMASCRIPT_LANG_SOURCES = \
language/ecmascript/spec.scm
ELISP_LANG_SOURCES = \
language/elisp/falias.scm \
language/elisp/lexer.scm \
language/elisp/parser.scm \
language/elisp/bindings.scm \
@ -142,8 +143,6 @@ ELISP_LANG_SOURCES = \
language/elisp/runtime.scm \
language/elisp/runtime/function-slot.scm \
language/elisp/runtime/value-slot.scm \
language/elisp/runtime/macros.scm \
language/elisp/runtime/subrs.scm \
language/elisp/spec.scm
BRAINFUCK_LANG_SOURCES = \
@ -374,6 +373,9 @@ WEB_SOURCES = \
EXTRA_DIST += oop/ChangeLog-2008
ELISP_SOURCES = \
language/elisp/boot.el
NOCOMP_SOURCES = \
ice-9/match.upstream.scm \
ice-9/psyntax.scm \

2
module/language/assembly/compile-bytecode.scm
View file

@ -133,6 +133,8 @@
((br-if-not-eq ,l) (write-break l))
((br-if-null ,l) (write-break l))
((br-if-not-null ,l) (write-break l))
((br-if-nil ,l) (write-break l))
((br-if-not-nil ,l) (write-break l))
((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))

4
module/language/assembly/disassemble.scm
View file

@ -125,7 +125,9 @@
(case inst
((list vector)
(list "~a element~:p" (apply make-int16 args)))
((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null)
((br
br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null
br-if-nil br-if-not-nil)
(list "-> ~A" (assq-ref labels (car args))))
((br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt)
(list "-> ~A" (assq-ref labels (caddr args))))

80
module/language/elisp/bindings.scm
View file

@ -19,21 +19,22 @@
;;; Code:
(define-module (language elisp bindings)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-8)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:export (make-bindings
mark-global-needed!
map-globals-needed
with-lexical-bindings
with-dynamic-bindings
get-lexical-binding))
with-function-bindings
get-lexical-binding
get-function-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
@ -41,64 +42,32 @@
;;; Record type used to hold the data necessary.
(define bindings-type
(make-record-type 'bindings '(needed-globals lexical-bindings)))
(define-record-type bindings
(%make-bindings lexical-bindings function-bindings)
bindings?
(lexical-bindings lexical-bindings)
(function-bindings function-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))))))))))
(%make-bindings (make-hash-table) (make-hash-table)))
;;; Get the current lexical binding (gensym it should refer to in the
;;; current scope) for a symbol or #f if it is dynamically bound.
(define (get-lexical-binding bindings sym)
(let* ((lex ((record-accessor bindings-type 'lexical-bindings)
bindings))
(let* ((lex (lexical-bindings bindings))
(slot (hash-ref lex sym #f)))
(if slot
(fluid-ref slot)
#f)))
(define (get-function-binding bindings symbol)
(and=> (hash-ref (function-bindings bindings) symbol)
fluid-ref))
;;; Establish a binding or mark a symbol as dynamically bound for the
;;; extent of calling proc.
@ -106,8 +75,7 @@
(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)))
(let ((lex (lexical-bindings bindings)))
(for-each (lambda (sym)
(if (not (hash-ref lex sym))
(hash-set! lex sym (make-fluid))))
@ -127,3 +95,13 @@
syms
(map (lambda (el) #f) syms)
proc))
(define (with-function-bindings bindings symbols gensyms thunk)
(let ((fb (function-bindings bindings)))
(for-each (lambda (symbol)
(if (not (hash-ref fb symbol))
(hash-set! fb symbol (make-fluid))))
symbols)
(with-fluids* (map (cut hash-ref fb <>) symbols)
gensyms
thunk)))

495
module/language/elisp/boot.el Normal file
View file

@ -0,0 +1,495 @@
;;; Guile Emacs Lisp -*- lexical-binding: t -*-
;;; Copyright (C) 2011 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:
(defmacro @ (module symbol)
`(guile-ref ,module ,symbol))
(defmacro eval-and-compile (&rest body)
`(progn
(eval-when-compile ,@body)
(progn ,@body)))
(eval-and-compile
(defun null (object)
(if object nil t))
(defun consp (object)
(%funcall (@ (guile) pair?) object))
(defun listp (object)
(if object (consp object) t))
(defun car (list)
(if list (%funcall (@ (guile) car) list) nil))
(defun cdr (list)
(if list (%funcall (@ (guile) cdr) list) nil))
(defun make-symbol (name)
(%funcall (@ (guile) make-symbol) name))
(defun signal (error-symbol data)
(%funcall (@ (guile) throw) 'elisp-condition error-symbol data)))
(defmacro lambda (&rest cdr)
`#'(lambda ,@cdr))
(defmacro prog1 (first &rest body)
(let ((temp (make-symbol "prog1-temp")))
`(let ((,temp ,first))
(declare (lexical ,temp))
,@body
,temp)))
(defmacro prog2 (form1 form2 &rest body)
`(progn ,form1 (prog1 ,form2 ,@body)))
(defmacro cond (&rest clauses)
(if (null clauses)
nil
(let ((first (car clauses))
(rest (cdr clauses)))
(if (listp first)
(let ((condition (car first))
(body (cdr first)))
(if (null body)
(let ((temp (make-symbol "cond-temp")))
`(let ((,temp ,condition))
(declare (lexical ,temp))
(if ,temp
,temp
(cond ,@rest))))
`(if ,condition
(progn ,@body)
(cond ,@rest))))
(signal 'wrong-type-argument `(listp ,first))))))
(defmacro and (&rest conditions)
(cond ((null conditions) t)
((null (cdr conditions)) (car conditions))
(t `(if ,(car conditions)
(and ,@(cdr conditions))
nil))))
(defmacro or (&rest conditions)
(cond ((null conditions) nil)
((null (cdr conditions)) (car conditions))
(t (let ((temp (make-symbol "or-temp")))
`(let ((,temp ,(car conditions)))
(declare (lexical ,temp))
(if ,temp
,temp
(or ,@(cdr conditions))))))))
(defmacro lexical-let (bindings &rest body)
(labels ((loop (list vars)
(if (null list)
`(let ,bindings
(declare (lexical ,@vars))
,@body)
(loop (cdr list)
(if (consp (car list))
`(,(car (car list)) ,@vars)
`(,(car list) ,@vars))))))
(loop bindings '())))
(defmacro lexical-let* (bindings &rest body)
(labels ((loop (list vars)
(if (null list)
`(let* ,bindings
(declare (lexical ,@vars))
,@body)
(loop (cdr list)
(if (consp (car list))
(cons (car (car list)) vars)
(cons (car list) vars))))))
(loop bindings '())))
(defmacro while (test &rest body)
(let ((loop (make-symbol "loop")))
`(labels ((,loop ()
(if ,test
(progn ,@body (,loop))
nil)))
(,loop))))
(defmacro unwind-protect (bodyform &rest unwindforms)
`(funcall (@ (guile) dynamic-wind)
#'(lambda () nil)
#'(lambda () ,bodyform)
#'(lambda () ,@unwindforms)))
(defun symbolp (object)
(%funcall (@ (guile) symbol?) object))
(defun functionp (object)
(%funcall (@ (guile) procedure?) object))
(defun symbol-function (symbol)
(let ((f (%funcall (@ (language elisp runtime) symbol-function)
symbol)))
(if (%funcall (@ (language elisp falias) falias?) f)
(%funcall (@ (language elisp falias) falias-object) f)
f)))
(defun eval (form)
(%funcall (@ (system base compile) compile)
form
(%funcall (@ (guile) symbol->keyword) 'from)
'elisp
(%funcall (@ (guile) symbol->keyword) 'to)
'value))
(defun %indirect-function (object)
(cond
((functionp object)
object)
((symbolp object) ;++ cycle detection
(%indirect-function (symbol-function object)))
((listp object)
(eval `(function ,object)))
(t
(signal 'invalid-function `(,object)))))
(defun apply (function &rest arguments)
(%funcall (@ (guile) apply)
(@ (guile) apply)
(%indirect-function function)
arguments))
(defun funcall (function &rest arguments)
(%funcall (@ (guile) apply)
(%indirect-function function)
arguments))
(defun fset (symbol definition)
(funcall (@ (language elisp runtime) set-symbol-function!)
symbol
(if (functionp definition)
definition
(funcall (@ (language elisp falias) make-falias)
#'(lambda (&rest args) (apply definition args))
definition)))
definition)
(defun load (file)
(funcall (@ (system base compile) compile-file)
file
(funcall (@ (guile) symbol->keyword) 'from)
'elisp
(funcall (@ (guile) symbol->keyword) 'to)
'value)
t)
;;; Equality predicates
(defun eq (obj1 obj2)
(if obj1
(funcall (@ (guile) eq?) obj1 obj2)
(null obj2)))
(defun eql (obj1 obj2)
(if obj1
(funcall (@ (guile) eqv?) obj1 obj2)
(null obj2)))
(defun equal (obj1 obj2)
(if obj1
(funcall (@ (guile) equal?) obj1 obj2)
(null obj2)))
;;; Symbols
;;; `symbolp' and `symbol-function' are defined above.
(fset 'symbol-value (@ (language elisp runtime) symbol-value))
(fset 'set (@ (language elisp runtime) set-symbol-value!))
(fset 'makunbound (@ (language elisp runtime) makunbound!))
(fset 'fmakunbound (@ (language elisp runtime) fmakunbound!))
(fset 'boundp (@ (language elisp runtime) symbol-bound?))
(fset 'fboundp (@ (language elisp runtime) symbol-fbound?))
(defun defvaralias (new-alias base-variable &optional docstring)
(let ((fluid (funcall (@ (language elisp runtime) symbol-fluid)
base-variable)))
(funcall (@ (language elisp runtime) set-symbol-fluid!)
new-alias
fluid)
base-variable))
;;; Numerical type predicates
(defun floatp (object)
(and (funcall (@ (guile) real?) object)
(or (funcall (@ (guile) inexact?) object)
(null (funcall (@ (guile) integer?) object)))))
(defun integerp (object)
(and (funcall (@ (guile) exact?) object)
(funcall (@ (guile) integer?) object)))
(defun numberp (object)
(funcall (@ (guile) real?) object))
(defun wholenump (object)
(and (funcall (@ (guile) exact?) object)
(funcall (@ (guile) integer?) object)
(>= object 0)))
(defun zerop (object)
(= object 0))
;;; Numerical comparisons
(fset '= (@ (guile) =))
(defun /= (num1 num2)
(null (= num1 num2)))
(fset '< (@ (guile) <))
(fset '<= (@ (guile) <=))
(fset '> (@ (guile) >))
(fset '>= (@ (guile) >=))
(defun max (&rest numbers)
(apply (@ (guile) max) numbers))
(defun min (&rest numbers)
(apply (@ (guile) min) numbers))
;;; Arithmetic functions
(fset '1+ (@ (guile) 1+))
(fset '1- (@ (guile) 1-))
(fset '+ (@ (guile) +))
(fset '- (@ (guile) -))
(fset '* (@ (guile) *))
(fset '% (@ (guile) modulo))
(fset 'abs (@ (guile) abs))
;;; Floating-point rounding
(fset 'ffloor (@ (guile) floor))
(fset 'fceiling (@ (guile) ceiling))
(fset 'ftruncate (@ (guile) truncate))
(fset 'fround (@ (guile) round))
;;; Numeric conversion
(defun float (arg)
(if (numberp arg)
(funcall (@ (guile) exact->inexact) arg)
(signal 'wrong-type-argument `(numberp ,arg))))
;;; List predicates
(fset 'not #'null)
(defun atom (object)
(null (consp object)))
(defun nlistp (object)
(null (listp object)))
;;; Lists
(fset 'cons (@ (guile) cons))
(fset 'list (@ (guile) list))
(fset 'make-list (@ (guile) make-list))
(fset 'append (@ (guile) append))
(fset 'reverse (@ (guile) reverse))
(defun car-safe (object)
(if (consp object)
(car object)
nil))
(defun cdr-safe (object)
(if (consp object)
(cdr object)
nil))
(defun setcar (cell newcar)
(if (consp cell)
(progn
(funcall (@ (guile) set-car!) cell newcar)
newcar)
(signal 'wrong-type-argument `(consp ,cell))))
(defun setcdr (cell newcdr)
(if (consp cell)
(progn
(funcall (@ (guile) set-cdr!) cell newcdr)
newcdr)
(signal 'wrong-type-argument `(consp ,cell))))
(defun nthcdr (n list)
(let ((i 0))
(while (< i n)
(setq list (cdr list)
i (+ i 1)))
list))
(defun nth (n list)
(car (nthcdr n list)))
(defun %member (elt list test)
(cond
((null list) nil)
((consp list)
(if (funcall test elt (car list))
list
(%member elt (cdr list) test)))
(t (signal 'wrong-type-argument `(listp ,list)))))
(defun member (elt list)
(%member elt list #'equal))
(defun memql (elt list)
(%member elt list #'eql))
(defun memq (elt list)
(%member elt list #'eq))
;;; Strings
(defun string (&rest characters)
(funcall (@ (guile) list->string)
(mapcar (@ (guile) integer->char) characters)))
;;; Sequences
(fset 'length (@ (guile) length))
(defun mapcar (function sequence)
(funcall (@ (guile) map) function sequence))
;;; Property lists
(defun %plist-member (plist property test)
(cond
((null plist) nil)
((consp plist)
(if (funcall test (car plist) property)
(cdr plist)
(%plist-member (cdr (cdr plist)) property test)))
(t (signal 'wrong-type-argument `(listp ,plist)))))
(defun %plist-get (plist property test)
(car (%plist-member plist property test)))
(defun %plist-put (plist property value test)
(let ((x (%plist-member plist property test)))
(if x
(progn (setcar x value) plist)
(cons property (cons value plist)))))
(defun plist-get (plist property)
(%plist-get plist property #'eq))
(defun plist-put (plist property value)
(%plist-put plist property value #'eq))
(defun plist-member (plist property)
(%plist-member plist property #'eq))
(defun lax-plist-get (plist property)
(%plist-get plist property #'equal))
(defun lax-plist-put (plist property value)
(%plist-put plist property value #'equal))
(defvar plist-function (funcall (@ (guile) make-object-property)))
(defun symbol-plist (symbol)
(funcall plist-function symbol))
(defun setplist (symbol plist)
(funcall (funcall (@ (guile) setter) plist-function) symbol plist))
(defun get (symbol propname)
(plist-get (symbol-plist symbol) propname))
(defun put (symbol propname value)
(setplist symbol (plist-put (symbol-plist symbol) propname value)))
;;; Nonlocal exits
(defmacro condition-case (var bodyform &rest handlers)
(let ((key (make-symbol "key"))
(error-symbol (make-symbol "error-symbol"))
(data (make-symbol "data"))
(conditions (make-symbol "conditions")))
(flet ((handler->cond-clause (handler)
`((or ,@(mapcar #'(lambda (c) `(memq ',c ,conditions))
(if (consp (car handler))
(car handler)
(list (car handler)))))
,@(cdr handler))))
`(funcall (@ (guile) catch)
'elisp-condition
#'(lambda () ,bodyform)
#'(lambda (,key ,error-symbol ,data)
(declare (lexical ,key ,error-symbol ,data))
(let ((,conditions
(get ,error-symbol 'error-conditions))
,@(if var
`((,var (cons ,error-symbol ,data)))
'()))
(declare (lexical ,conditions
,@(if var `(,var) '())))
(cond ,@(mapcar #'handler->cond-clause handlers)
(t (signal ,error-symbol ,data)))))))))
(put 'error 'error-conditions '(error))
(put 'wrong-type-argument 'error-conditions '(wrong-type-argument error))
(put 'invalid-function 'error-conditions '(invalid-function error))
(put 'no-catch 'error-conditions '(no-catch error))
(put 'throw 'error-conditions '(throw))
(defvar %catch nil)
(defmacro catch (tag &rest body)
(let ((tag-value (make-symbol "tag-value"))
(c (make-symbol "c"))
(data (make-symbol "data")))
`(let ((,tag-value ,tag))
(declare (lexical ,tag-value))
(condition-case ,c
(let ((%catch t))
,@body)
(throw
(let ((,data (cdr ,c)))
(declare (lexical ,data))
(if (eq (car ,data) ,tag-value)
(car (cdr ,data))
(apply #'throw ,data))))))))
(defun throw (tag value)
(signal (if %catch 'throw 'no-catch) (list tag value)))
;;; I/O
(defun princ (object)
(funcall (@ (guile) display) object))
(defun print (object)
(funcall (@ (guile) write) object))
(defun terpri ()
(funcall (@ (guile) newline)))
(defun format* (stream string &rest args)
(apply (@ (guile) format) stream string args))

948
module/language/elisp/compile-tree-il.scm
View file

File diff suppressed because it is too large Load diff

27
module/language/elisp/falias.scm Normal file
View file

@ -0,0 +1,27 @@
(define-module (language elisp falias)
#:export (falias?
make-falias
falias-function
falias-object))
(define <falias-vtable>
(make-struct <applicable-struct-vtable>
0
(make-struct-layout "pwpw")
(lambda (object port)
(format port "#<falias ~S>" (falias-object object)))))
(set-struct-vtable-name! <falias-vtable> 'falias)
(define (falias? object)
(and (struct? object)
(eq? (struct-vtable object) <falias-vtable>)))
(define (make-falias f object)
(make-struct <falias-vtable> 0 f object))
(define (falias-function object)
(struct-ref object 0))
(define (falias-object object)
(struct-ref object 1))

33
module/language/elisp/lexer.scm
View file

@ -252,7 +252,15 @@
;;; Main lexer routine, which is given a port and does look for the next
;;; token.
(define lexical-binding-regexp
(make-regexp
"-\\*-(|.*;)[ \t]*lexical-binding:[ \t]*([^;]*[^ \t;]).*-\\*-"))
(define (lex port)
(define (lexical-binding-value string)
(and=> (regexp-exec lexical-binding-regexp string)
(lambda (match)
(not (member (match:substring match 2) '("nil" "()"))))))
(let ((return (let ((file (if (file-port? port)
(port-filename port)
#f))
@ -283,11 +291,19 @@
(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)))))
(if (= (port-line port) 0)
(let iterate ((chars '()))
(let ((cur (read-char port)))
(if (or (eof-object? cur) (char=? cur #\newline))
(let ((string (list->string (reverse chars))))
(return 'set-lexical-binding-mode!
(lexical-binding-value string)))
(iterate (cons cur chars)))))
(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)))
@ -321,7 +337,12 @@
(let ((mark (get-circular-marker port)))
(return (car mark) (cdr mark))))
((#\')
(return 'function #f)))))
(return 'function #f))
((#\:)
(call-with-values
(lambda () (get-symbol-or-number port))
(lambda (type str)
(return 'symbol (make-symbol str))))))))
;; Parentheses and other special-meaning single characters.
((#\() (return 'paren-open #f))
((#\)) (return 'paren-close #f))

2
module/language/elisp/parser.scm
View file

@ -201,6 +201,8 @@
(setter expr)
(force-promises! expr)
expr))
((set-lexical-binding-mode!)
(return `(%set-lexical-binding-mode ,(cdr token))))
(else
(parse-error token "expected expression, got" token)))))

143
module/language/elisp/runtime.scm
View file

@ -25,11 +25,17 @@
function-slot-module
elisp-bool
ensure-fluid!
reference-variable
set-variable!
runtime-error
macro-error)
#:export-syntax (built-in-func built-in-macro defspecial prim))
symbol-fluid
set-symbol-fluid!
symbol-value
set-symbol-value!
symbol-function
set-symbol-function!
symbol-bound?
symbol-fbound?
makunbound!
fmakunbound!)
#:export-syntax (defspecial prim))
;;; This module provides runtime support for the Elisp front-end.
@ -47,22 +53,6 @@
(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
@ -77,39 +67,68 @@
(module-define! resolved sym fluid)
(module-export! resolved `(,sym))))))
(define (reference-variable module sym)
(let ((resolved (resolve-module module)))
(cond
((equal? module function-slot-module)
(module-ref resolved sym))
(else
(ensure-fluid! module sym)
(fluid-ref (module-ref resolved sym))))))
(define (symbol-fluid symbol)
(let ((module (resolve-module value-slot-module)))
(ensure-fluid! value-slot-module symbol) ;++ implicit special proclamation
(module-ref module symbol)))
(define (set-variable! module sym value)
(let ((intf (resolve-interface module))
(resolved (resolve-module module)))
(cond
((equal? module function-slot-module)
(cond
((module-defined? intf sym)
(module-set! resolved sym value))
(else
(module-define! resolved sym value)
(module-export! resolved `(,sym)))))
(else
(ensure-fluid! module sym)
(fluid-set! (module-ref resolved sym) value))))
(define (set-symbol-fluid! symbol fluid)
(let ((module (resolve-module value-slot-module)))
(module-define! module symbol fluid)
(module-export! module (list symbol)))
fluid)
(define (symbol-value symbol)
(fluid-ref (symbol-fluid symbol)))
(define (set-symbol-value! symbol value)
(fluid-set! (symbol-fluid symbol) value)
value)
;;; Define a predefined function or predefined macro for use in the
;;; function-slot and macro-slot modules, respectively.
(define (symbol-function symbol)
(let ((module (resolve-module function-slot-module)))
(module-ref module symbol)))
(define-syntax built-in-func
(syntax-rules ()
((_ name value)
(begin
(define-public name value)))))
(define (set-symbol-function! symbol value)
(let ((module (resolve-module function-slot-module)))
(module-define! module symbol value)
(module-export! module (list symbol)))
value)
(define (symbol-bound? symbol)
(and
(module-bound? (resolve-interface value-slot-module) symbol)
(let ((var (module-variable (resolve-module value-slot-module)
symbol)))
(and (variable-bound? var)
(if (fluid? (variable-ref var))
(fluid-bound? (variable-ref var))
#t)))))
(define (symbol-fbound? symbol)
(and
(module-bound? (resolve-interface function-slot-module) symbol)
(variable-bound?
(module-variable (resolve-module function-slot-module)
symbol))))
(define (makunbound! symbol)
(if (module-bound? (resolve-interface value-slot-module) symbol)
(let ((var (module-variable (resolve-module value-slot-module)
symbol)))
(if (and (variable-bound? var) (fluid? (variable-ref var)))
(fluid-unset! (variable-ref var))
(variable-unset! var))))
symbol)
(define (fmakunbound! symbol)
(if (module-bound? (resolve-interface function-slot-module) symbol)
(variable-unset! (module-variable
(resolve-module function-slot-module)
symbol)))
symbol)
;;; Define a predefined macro for use in the function-slot module.
(define (make-id template-id . data)
(let ((append-symbols
@ -125,30 +144,10 @@
datum))
data)))))
(define-syntax built-in-macro
(lambda (x)
(syntax-case x ()
((_ name value)
(with-syntax ((scheme-name (make-id #'name 'macro- #'name)))
#'(begin
(define-public scheme-name
(make-fluid (cons 'macro value)))))))))
(define-syntax defspecial
(lambda (x)
(syntax-case x ()
((_ name args body ...)
(with-syntax ((scheme-name (make-id #'name 'compile- #'name)))
#'(begin
(define scheme-name
(make-fluid
(cons 'special-operator
(lambda args body ...))))))))))
;;; Call a guile-primitive that may be rebound for elisp and thus needs
;;; absolute addressing.
(define-syntax prim
(syntax-rules ()
((_ sym args ...)
((@ (guile) sym) args ...))))
#'(define scheme-name
(cons 'special-operator (lambda args body ...))))))))

119
module/language/elisp/runtime/function-slot.scm
View file

@ -17,142 +17,47 @@
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (language elisp runtime function-slot)
#:use-module (language elisp runtime subrs)
#:use-module ((language elisp runtime macros)
#:select
((macro-lambda . lambda)
(macro-prog1 . prog1)
(macro-prog2 . prog2)
(macro-when . when)
(macro-unless . unless)
(macro-cond . cond)
(macro-and . and)
(macro-or . or)
(macro-dotimes . dotimes)
(macro-dolist . dolist)
(macro-catch . catch)
(macro-unwind-protect . unwind-protect)
(macro-pop . pop)
(macro-push . push)))
#:use-module ((language elisp compile-tree-il)
#:select
((compile-progn . progn)
(compile-eval-when-compile . eval-when-compile)
(compile-if . if)
(compile-defconst . defconst)
(compile-defvar . defvar)
(compile-setq . setq)
(compile-let . let)
(compile-lexical-let . lexical-let)
(compile-flet . flet)
(compile-labels . labels)
(compile-let* . let*)
(compile-lexical-let* . lexical-let*)
(compile-flet* . flet*)
(compile-with-always-lexical . with-always-lexical)
(compile-guile-ref . guile-ref)
(compile-guile-primitive . guile-primitive)
(compile-while . while)
(compile-function . function)
(compile-defun . defun)
(compile-defmacro . defmacro)
(#{compile-`}# . #{`}#)
(compile-quote . quote)))
(compile-quote . quote)
(compile-%funcall . %funcall)
(compile-%set-lexical-binding-mode
. %set-lexical-binding-mode)))
#:duplicates (last)
;; special operators
#:re-export (progn
eval-when-compile
if
defconst
defvar
setq
let
lexical-let
flet
labels
let*
lexical-let*
flet*
with-always-lexical
guile-ref
guile-primitive
while
function
defun
defmacro
#{`}#
quote)
;; macros
#:re-export (lambda
prog1
prog2
when
unless
cond
and
or
dotimes
dolist
catch
unwind-protect
pop
push)
;; functions
#:re-export (eq
equal
floatp
integerp
numberp
wholenump
zerop
=
/=
<
<=
>
>=
max
min
abs
float
1+
1-
+
-
*
%
ffloor
fceiling
ftruncate
fround
consp
atomp
listp
nlistp
null
car
cdr
car-safe
cdr-safe
nth
nthcdr
length
cons
list
make-list
append
reverse
copy-tree
number-sequence
setcar
setcdr
symbol-value
symbol-function
set
fset
makunbound
fmakunbound
boundp
fboundp
apply
funcall
throw
not
eval
load))
quote
%funcall
%set-lexical-binding-mode)
#:pure)

208
module/language/elisp/runtime/macros.scm
View file

@ -1,208 +0,0 @@
;;; Guile Emacs Lisp
;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
(define-module (language elisp runtime macros)
#:use-module (language elisp runtime))
;;; This module contains the macro definitions of elisp symbols. In
;;; contrast to the other runtime modules, those are used directly
;;; during compilation, of course, so not really in runtime. But I
;;; think it fits well to the others here.
(built-in-macro lambda
(lambda cdr
`(function (lambda ,@cdr))))
;;; The prog1 and prog2 constructs can easily be defined as macros using
;;; progn and some lexical-let's to save the intermediate value to
;;; return at the end.
(built-in-macro prog1
(lambda (form1 . rest)
(let ((temp (gensym)))
`(lexical-let ((,temp ,form1))
,@rest
,temp))))
(built-in-macro prog2
(lambda (form1 form2 . rest)
`(progn ,form1 (prog1 ,form2 ,@rest))))
;;; Define the conditionals when and unless as macros.
(built-in-macro when
(lambda (condition . thens)
`(if ,condition (progn ,@thens) nil)))
(built-in-macro unless
(lambda (condition . elses)
`(if ,condition nil (progn ,@elses))))
;;; Impement the cond form as nested if's. A special case is a
;;; (condition) subform, in which case we need to return the condition
;;; itself if it is true and thus save it in a local variable before
;;; testing it.
(built-in-macro cond
(lambda (. clauses)
(let iterate ((tail clauses))
(if (null? tail)
'nil
(let ((cur (car tail))
(rest (iterate (cdr tail))))
(prim cond
((prim or (not (list? cur)) (null? cur))
(macro-error "invalid clause in cond" cur))
((null? (cdr cur))
(let ((var (gensym)))
`(lexical-let ((,var ,(car cur)))
(if ,var
,var
,rest))))
(else
`(if ,(car cur)
(progn ,@(cdr cur))
,rest))))))))
;;; The `and' and `or' forms can also be easily defined with macros.
(built-in-macro and
(case-lambda
(() 't)
((x) x)
((x . args)
(let iterate ((x x) (tail args))
(if (null? tail)
x
`(if ,x
,(iterate (car tail) (cdr tail))
nil))))))
(built-in-macro or
(case-lambda
(() 'nil)
((x) x)
((x . args)
(let iterate ((x x) (tail args))
(if (null? tail)
x
(let ((var (gensym)))
`(lexical-let ((,var ,x))
(if ,var
,var
,(iterate (car tail) (cdr tail))))))))))
;;; Define the dotimes and dolist iteration macros.
(built-in-macro dotimes
(lambda (args . body)
(if (prim or
(not (list? args))
(< (length args) 2)
(> (length args) 3))
(macro-error "invalid dotimes arguments" args)
(let ((var (car args))
(count (cadr args)))
(if (not (symbol? var))
(macro-error "expected symbol as dotimes variable"))
`(let ((,var 0))
(while ((guile-primitive <) ,var ,count)
,@body
(setq ,var ((guile-primitive 1+) ,var)))
,@(if (= (length args) 3)
(list (caddr args))
'()))))))
(built-in-macro dolist
(lambda (args . body)
(if (prim or
(not (list? args))
(< (length args) 2)
(> (length args) 3))
(macro-error "invalid dolist arguments" args)
(let ((var (car args))
(iter-list (cadr args))
(tailvar (gensym)))
(if (not (symbol? var))
(macro-error "expected symbol as dolist variable")
`(let (,var)
(lexical-let ((,tailvar ,iter-list))
(while ((guile-primitive not)
((guile-primitive null?) ,tailvar))
(setq ,var ((guile-primitive car) ,tailvar))
,@body
(setq ,tailvar ((guile-primitive cdr) ,tailvar)))
,@(if (= (length args) 3)
(list (caddr args))
'()))))))))
;;; Exception handling. unwind-protect and catch are implemented as
;;; macros (throw is a built-in function).
;;; catch and throw can mainly be implemented directly using Guile's
;;; primitives for exceptions, the only difficulty is that the keys used
;;; within Guile must be symbols, while elisp allows any value and
;;; checks for matches using eq (eq?). We handle this by using always #t
;;; as key for the Guile primitives and check for matches inside the
;;; handler; if the elisp keys are not eq?, we rethrow the exception.
(built-in-macro catch
(lambda (tag . body)
(if (null? body)
(macro-error "catch with empty body"))
(let ((tagsym (gensym)))
`(lexical-let ((,tagsym ,tag))
((guile-primitive catch)
#t
(lambda () ,@body)
,(let* ((dummy-key (gensym))
(elisp-key (gensym))
(value (gensym))
(arglist `(,dummy-key ,elisp-key ,value)))
`(with-always-lexical
,arglist
(lambda ,arglist
(if (eq ,elisp-key ,tagsym)
,value
((guile-primitive throw) ,dummy-key ,elisp-key
,value))))))))))
;;; unwind-protect is just some weaker construct as dynamic-wind, so
;;; straight-forward to implement.
(built-in-macro unwind-protect
(lambda (body . clean-ups)
(if (null? clean-ups)
(macro-error "unwind-protect without cleanup code"))
`((guile-primitive dynamic-wind)
(lambda () nil)
(lambda () ,body)
(lambda () ,@clean-ups))))
;;; Pop off the first element from a list or push one to it.
(built-in-macro pop
(lambda (list-name)
`(prog1 (car ,list-name)
(setq ,list-name (cdr ,list-name)))))
(built-in-macro push
(lambda (new-el list-name)
`(setq ,list-name (cons ,new-el ,list-name))))

383
module/language/elisp/runtime/subrs.scm
View file

@ -1,383 +0,0 @@
;;; Guile Emacs Lisp
;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;; 02110-1301 USA
;;; Code:
(define-module (language elisp runtime subrs)
#:use-module (language elisp runtime)
#:use-module (system base compile))
;;; This module contains the function-slots of elisp symbols. Elisp
;;; built-in functions are implemented as predefined function bindings
;;; here.
;;; Equivalence and equalness predicates.
(built-in-func eq
(lambda (a b)
(elisp-bool (eq? a b))))
(built-in-func equal
(lambda (a b)
(elisp-bool (equal? a b))))
;;; Number predicates.
(built-in-func floatp
(lambda (num)
(elisp-bool (and (real? num)
(or (inexact? num)
(prim not (integer? num)))))))
(built-in-func integerp
(lambda (num)
(elisp-bool (and (exact? num)
(integer? num)))))
(built-in-func numberp
(lambda (num)
(elisp-bool (real? num))))
(built-in-func wholenump
(lambda (num)
(elisp-bool (and (exact? num)
(integer? num)
(prim >= num 0)))))
(built-in-func zerop
(lambda (num)
(elisp-bool (prim = num 0))))
;;; Number comparisons.
(built-in-func =
(lambda (num1 num2)
(elisp-bool (prim = num1 num2))))
(built-in-func /=
(lambda (num1 num2)
(elisp-bool (prim not (prim = num1 num2)))))
(built-in-func <
(lambda (num1 num2)
(elisp-bool (prim < num1 num2))))
(built-in-func <=
(lambda (num1 num2)
(elisp-bool (prim <= num1 num2))))
(built-in-func >
(lambda (num1 num2)
(elisp-bool (prim > num1 num2))))
(built-in-func >=
(lambda (num1 num2)
(elisp-bool (prim >= num1 num2))))
(built-in-func max
(lambda (. nums)
(prim apply (@ (guile) max) nums)))
(built-in-func min
(lambda (. nums)
(prim apply (@ (guile) min) nums)))
(built-in-func abs
(@ (guile) abs))
;;; Number conversion.
(built-in-func float
(lambda (num)
(if (exact? num)
(exact->inexact num)
num)))
;;; TODO: truncate, floor, ceiling, round.
;;; Arithmetic functions.
(built-in-func 1+ (@ (guile) 1+))
(built-in-func 1- (@ (guile) 1-))
(built-in-func + (@ (guile) +))
(built-in-func - (@ (guile) -))
(built-in-func * (@ (guile) *))
(built-in-func % (@ (guile) modulo))
;;; TODO: / with correct integer/real behaviour, mod (for floating-piont
;;; values).
;;; Floating-point rounding operations.
(built-in-func ffloor (@ (guile) floor))
(built-in-func fceiling (@ (guile) ceiling))
(built-in-func ftruncate (@ (guile) truncate))
(built-in-func fround (@ (guile) round))
;;; List predicates.
(built-in-func consp
(lambda (el)
(elisp-bool (pair? el))))
(built-in-func atomp
(lambda (el)
(elisp-bool (prim not (pair? el)))))
(built-in-func listp
(lambda (el)
(elisp-bool (or (pair? el) (null? el)))))
(built-in-func nlistp
(lambda (el)
(elisp-bool (and (prim not (pair? el))
(prim not (null? el))))))
(built-in-func null
(lambda (el)
(elisp-bool (null? el))))
;;; Accessing list elements.
(built-in-func car
(lambda (el)
(if (null? el)
nil-value
(prim car el))))
(built-in-func cdr
(lambda (el)
(if (null? el)
nil-value
(prim cdr el))))
(built-in-func car-safe
(lambda (el)
(if (pair? el)
(prim car el)
nil-value)))
(built-in-func cdr-safe
(lambda (el)
(if (pair? el)
(prim cdr el)
nil-value)))
(built-in-func nth
(lambda (n lst)
(if (negative? n)
(prim car lst)
(let iterate ((i n)
(tail lst))
(cond
((null? tail) nil-value)
((zero? i) (prim car tail))
(else (iterate (prim 1- i) (prim cdr tail))))))))
(built-in-func nthcdr
(lambda (n lst)
(if (negative? n)
lst
(let iterate ((i n)
(tail lst))
(cond
((null? tail) nil-value)
((zero? i) tail)
(else (iterate (prim 1- i) (prim cdr tail))))))))
(built-in-func length (@ (guile) length))
;;; Building lists.
(built-in-func cons (@ (guile) cons))
(built-in-func list (@ (guile) list))
(built-in-func make-list
(lambda (len obj)
(prim make-list len obj)))
(built-in-func append (@ (guile) append))
(built-in-func reverse (@ (guile) reverse))
(built-in-func copy-tree (@ (guile) copy-tree))
(built-in-func number-sequence
(lambda (from . rest)
(if (prim > (prim length rest) 2)
(runtime-error "too many arguments for number-sequence"
(prim cdddr rest))
(if (null? rest)
`(,from)
(let ((to (prim car rest))
(sep (if (or (null? (prim cdr rest))
(eq? nil-value (prim cadr rest)))
1
(prim cadr rest))))
(cond
((or (eq? nil-value to) (prim = to from)) `(,from))
((and (zero? sep) (prim not (prim = from to)))
(runtime-error "infinite list in number-sequence"))
((prim < (prim * to sep) (prim * from sep)) '())
(else
(let iterate ((i (prim +
from
(prim *
sep
(prim quotient
(prim abs
(prim -
to
from))
(prim abs sep)))))
(result '()))
(if (prim = i from)
(prim cons i result)
(iterate (prim - i sep)
(prim cons i result)))))))))))
;;; Changing lists.
(built-in-func setcar
(lambda (cell val)
(if (and (null? cell) (null? val))
#nil
(prim set-car! cell val))
val))
(built-in-func setcdr
(lambda (cell val)
(if (and (null? cell) (null? val))
#nil
(prim set-cdr! cell val))
val))
;;; Accessing symbol bindings for symbols known only at runtime.
(built-in-func symbol-value
(lambda (sym)
(reference-variable value-slot-module sym)))
(built-in-func symbol-function
(lambda (sym)
(reference-variable function-slot-module sym)))
(built-in-func set
(lambda (sym value)
(set-variable! value-slot-module sym value)))
(built-in-func fset
(lambda (sym value)
(set-variable! function-slot-module sym value)))
(built-in-func makunbound
(lambda (sym)
(if (module-bound? (resolve-interface value-slot-module) sym)
(let ((var (module-variable (resolve-module value-slot-module)
sym)))
(if (and (variable-bound? var) (fluid? (variable-ref var)))
(fluid-unset! (variable-ref var))
(variable-unset! var))))
sym))
(built-in-func fmakunbound
(lambda (sym)
(if (module-bound? (resolve-interface function-slot-module) sym)
(let ((var (module-variable
(resolve-module function-slot-module)
sym)))
(if (and (variable-bound? var) (fluid? (variable-ref var)))
(fluid-unset! (variable-ref var))
(variable-unset! var))))
sym))
(built-in-func boundp
(lambda (sym)
(elisp-bool
(and
(module-bound? (resolve-interface value-slot-module) sym)
(let ((var (module-variable (resolve-module value-slot-module)
sym)))
(and (variable-bound? var)
(if (fluid? (variable-ref var))
(fluid-bound? (variable-ref var))
#t)))))))
(built-in-func fboundp
(lambda (sym)
(elisp-bool
(and
(module-bound? (resolve-interface function-slot-module) sym)
(let* ((var (module-variable (resolve-module function-slot-module)
sym)))
(and (variable-bound? var)
(if (fluid? (variable-ref var))
(fluid-bound? (variable-ref var))
#t)))))))
;;; Function calls. These must take care of special cases, like using
;;; symbols or raw lambda-lists as functions!
(built-in-func apply
(lambda (func . args)
(let ((real-func (cond
((symbol? func)
(reference-variable function-slot-module func))
((list? func)
(if (and (prim not (null? func))
(eq? (prim car func) 'lambda))
(compile func #:from 'elisp #:to 'value)
(runtime-error "list is not a function"
func)))
(else func))))
(prim apply (@ (guile) apply) real-func args))))
(built-in-func funcall
(lambda (func . args)
(apply func args)))
;;; Throw can be implemented as built-in function.
(built-in-func throw
(lambda (tag value)
(prim throw 'elisp-exception tag value)))
;;; Miscellaneous.
(built-in-func not
(lambda (x)
(if x nil-value t-value)))
(built-in-func eval
(lambda (form)
(compile form #:from 'elisp #:to 'value)))
(built-in-func load
(lambda* (file)
(compile-file file #:from 'elisp #:to 'value)
#t))

3
module/language/elisp/runtime/value-slot.scm
View file

@ -18,6 +18,7 @@
;;; Code:
(define-module (language elisp runtime value-slot))
(define-module (language elisp runtime value-slot)
#:pure)
;;; This module contains the value-slots of elisp symbols.

4
module/language/elisp/spec.scm
View file

@ -22,6 +22,7 @@
#:use-module (language elisp compile-tree-il)
#:use-module (language elisp parser)
#:use-module (system base language)
#:use-module (system base compile)
#:export (elisp))
(define-language elisp
@ -29,3 +30,6 @@
#:reader (lambda (port env) (read-elisp port))
#:printer write
#:compilers `((tree-il . ,compile-tree-il)))
(compile-and-load (%search-load-path "language/elisp/boot.el")
#:from 'elisp)

7
module/language/tree-il/compile-glil.scm
View file

@ -110,6 +110,7 @@
((list? . 1) . list?)
((symbol? . 1) . symbol?)
((vector? . 1) . vector?)
((nil? . 1) . nil?)
(list . list)
(vector . vector)
((class-of . 1) . class-of)
@ -527,6 +528,9 @@
((null? ,x)
(comp-push x)
(emit-branch src 'br-if-not-null L1))
((nil? ,x)
(comp-push x)
(emit-branch src 'br-if-not-nil L1))
((not ,x)
(record-case x
((<primcall> name args)
@ -538,6 +542,9 @@
((null? ,x)
(comp-push x)
(emit-branch src 'br-if-null L1))
((nil? ,x)
(comp-push x)
(emit-branch src 'br-if-nil L1))
(else
(comp-push x)
(emit-branch src 'br-if L1))))

3
module/language/tree-il/primitives.scm
View file

@ -46,6 +46,7 @@
ash logand logior logxor
not
pair? null? list? symbol? vector? string? struct?
nil?
acons cons cons*
list vector
@ -141,6 +142,7 @@
+ * - / 1- 1+ quotient remainder modulo
not
pair? null? list? symbol? vector? struct? string?
nil?
string-length vector-length
;; These all should get expanded out by expand-primitives!.
caar cadr cdar cddr
@ -168,6 +170,7 @@
ash logand logior logxor
not
pair? null? list? symbol? vector? acons cons cons*
nil?
list vector
car cdr
set-car! set-cdr!

136
test-suite/tests/elisp-compiler.test
View file

@ -47,6 +47,8 @@
; Test control structures.
; ========================
(compile '(%set-lexical-binding-mode #nil) #:from 'elisp #:to 'value)
(with-test-prefix/compile "Sequencing"
(pass-if-equal "progn" 1
@ -54,6 +56,9 @@
(setq a (1+ a))
a))
(pass-if-equal "empty progn" #nil
(progn))
(pass-if "prog1"
(progn (setq a 0)
(setq b (prog1 a (setq a (1+ a))))
@ -77,17 +82,8 @@
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 "if with no else" #nil
(if nil t))
(pass-if-equal "empty cond" nil-value
(cond))
@ -127,27 +123,7 @@
(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)))))
prod)))
(with-test-prefix/compile "Exceptions"
@ -169,7 +145,7 @@
(= (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)))
(= (catch mylist (catch (list 1 2) (throw mylist 1) 2) 3) 1)))
(pass-if "unwind-protect"
(progn (setq a 0 b 1 c 1)
@ -246,6 +222,8 @@
(b a))
b)))
(pass-if-equal "empty let" #nil (let ()))
(pass-if "let*"
(progn (setq a 0)
(and (let* ((a 1)
@ -257,6 +235,9 @@
(= a 0)
(not (boundp 'b)))))
(pass-if-equal "empty let*" #nil
(let* ()))
(pass-if "local scope"
(progn (setq a 0)
(setq b (let (a)
@ -303,9 +284,11 @@
(lexical-let ((a 2))
(and (= a 2) (equal (dynvals) '(1 . 1))
(let ((a 3) (b a))
(declare (lexical a))
(and (= a 3) (= b 2)
(equal (dynvals) '(1 . 2))))
(let* ((a 4) (b a))
(declare (lexical a))
(and (= a 4) (= b 4)
(equal (dynvals) '(1 . 4))))
(= a 2)))
@ -316,8 +299,11 @@
(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 (a)
(declare (lexical a))
(and (= a 3) (= b 42) (= (dyna) 1))) 3)
((lambda () (let ((a 3))
(declare (lexical a))
(and (= a 3) (= (dyna) 1)))))
(= a 2) (= (dyna) 1)))
(= a 1)))
@ -336,34 +322,13 @@
(= (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)
(lexical-let (a c)
((lambda (a b &optional c)
(declare (lexical a c))
(and (= a 3) (= (dyna) 1)
(= b 2) (= (dynb) 2)
(= c 1)))
@ -373,9 +338,10 @@
; is tail-optimized by doing a deep recursion that would otherwise overflow
; the stack.
(pass-if "lexical lambda tail-recursion"
(with-always-lexical (i)
(lexical-let (i)
(setq to 1000000)
(defun iteration-1 (i)
(declare (lexical i))
(if (< i to)
(iteration-1 (1+ i))))
(iteration-1 0)
@ -422,14 +388,17 @@
((lambda (a b c) c) 1 2 3))
(pass-if-equal "optional argument" 3
((function (lambda (a &optional b c) c)) 1 2 3))
((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)))
(pass-if "rest missing"
(null ((lambda (a b &rest c) c) 1 2)))
(pass-if-equal "empty lambda" #nil
((lambda ()))))
(with-test-prefix/compile "Function Definitions"
@ -453,18 +422,16 @@
(not (fboundp 'a))
(= a 1))))
(pass-if "flet and flet*"
(pass-if "flet"
(progn (defun foobar () 42)
(defun test () (foobar))
(and (= (test) 42)
(flet ((foobar (lambda () 0))
(myfoo (symbol-function 'foobar)))
(flet ((foobar () 0)
(myfoo ()
(funcall (symbol-function 'foobar))))
(and (= (myfoo) 42)
(= (test) 42)))
(flet* ((foobar (lambda () 0))
(myfoo (symbol-function 'foobar)))
(= (myfoo) 42))
(flet (foobar)
(flet ((foobar () nil))
(defun foobar () 0)
(= (test) 42))
(= (test) 42)))))
@ -563,8 +530,8 @@
(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)))))))
(eq some-string some-string) (not (eq some-string (string 97 98 99)))
(eq some-list some-list) (not (eq some-list (list 1 2)))))))
(with-test-prefix/compile "Number Built-Ins"
@ -607,11 +574,11 @@
(with-test-prefix/compile "List Built-Ins"
(pass-if "consp and atomp"
(pass-if "consp and atom"
(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)))))
(atom 'a) (atom '()) (atom -1.5) (atom "abc")
(not (atom '(1 . 2))) (not (atom '(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)
@ -628,15 +595,6 @@
(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)
@ -662,20 +620,6 @@
(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)