# -*- 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)
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 \
+ $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
$(top_builddir)/meta/uninstalled-env \
- guild compile --target="$(host)" $(GUILE_WARNINGS) -o "$@" "$<"
+ guild compile --target="$(host)" $(GUILE_WARNINGS) \
+ -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 $(GUILE_WARNINGS) --from=elisp -o "$@" "$<"
++ $(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 "$@" "$<"
#define scm_from_off64_t scm_from_int64
+\f
+
+#if defined (vms)
+/* VMS: Implement SCM_I_SETJMP in terms of setjump. */
+extern int setjump(scm_i_jmp_buf env);
+extern int longjump(scm_i_jmp_buf env, int ret);
+#define SCM_I_SETJMP setjump
+#define SCM_I_LONGJMP longjump
+
+#elif defined (_CRAY1)
+/* Cray: Implement SCM_I_SETJMP in terms of setjump. */
+extern int setjump(scm_i_jmp_buf env);
+extern int longjump(scm_i_jmp_buf env, int ret);
+#define SCM_I_SETJMP setjump
+#define SCM_I_LONGJMP longjump
+
+#elif defined (__ia64__)
+/* IA64: Implement SCM_I_SETJMP in terms of getcontext. */
+# define SCM_I_SETJMP(JB) \
+ ( (JB).fresh = 1, \
+ getcontext (&((JB).ctx)), \
+ ((JB).fresh ? ((JB).fresh = 0, 0) : 1) )
+# define SCM_I_LONGJMP(JB,VAL) scm_ia64_longjmp (&(JB), VAL)
+void scm_ia64_longjmp (scm_i_jmp_buf *, int);
+
+#else
+/* All other systems just use setjmp and longjmp. */
+
+#define SCM_I_SETJMP setjmp
+#define SCM_I_LONGJMP longjmp
+#endif
+
+\f
+
+#define SCM_ASYNC_TICK \
+ do \
+ { \
+ if (SCM_UNLIKELY (SCM_I_CURRENT_THREAD->pending_asyncs)) \
+ scm_async_tick (); \
+ } \
+ while (0)
+
+#define SCM_ASYNC_TICK_WITH_CODE(thr, stmt) \
+ do \
+ { \
+ if (SCM_UNLIKELY (thr->pending_asyncs)) \
+ { \
+ stmt; \
+ scm_async_tick (); \
+ } \
+ } \
+ while (0)
+
+
+\f
+
/* The endianness marker in objcode. */
#ifdef WORDS_BIGENDIAN
# define SCM_OBJCODE_ENDIANNESS "BE"
#define SCM_OBJCODE_WORD_SIZE SCM_CPP_STRINGIFY (SIZEOF_VOID_P)
/* Major and minor versions must be single characters. */
-#define SCM_OBJCODE_MAJOR_VERSION 2
+#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 \
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))
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))
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)));
* Basic data
*/
- VM_DEFINE_FUNCTION (140, cons, "cons", 2)
+ VM_DEFINE_FUNCTION (142, cons, "cons", 2)
{
ARGS2 (x, y);
CONS (x, x, y);
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);
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);
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);
}
#endif
- VM_DEFINE_FUNCTION (150, add, "add", 2)
+ VM_DEFINE_FUNCTION (152, add, "add", 2)
{
#ifndef ASM_ADD
FUNC2 (+, scm_sum);
#endif
}
- VM_DEFINE_FUNCTION (151, add1, "add1", 1)
+ VM_DEFINE_FUNCTION (153, add1, "add1", 1)
{
ARGS1 (x);
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);
#endif
}
- VM_DEFINE_FUNCTION (153, sub1, "sub1", 1)
+ VM_DEFINE_FUNCTION (155, sub1, "sub1", 1)
{
ARGS1 (x);
# 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))
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))
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))
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))
}
\f
- VM_DEFINE_FUNCTION (163, string_length, "string-length", 1)
+/*
+ * Strings
+ */
+
- VM_DEFINE_FUNCTION (164, string_ref, "string-ref", 2)
++VM_DEFINE_FUNCTION (165, string_length, "string-length", 1)
+{
+ ARGS1 (str);
+ if (SCM_LIKELY (scm_is_string (str)))
+ RETURN (SCM_I_MAKINUM (scm_i_string_length (str)));
+ else
+ {
+ SYNC_REGISTER ();
+ RETURN (scm_string_length (str));
+ }
+}
+
++VM_DEFINE_FUNCTION (166, string_ref, "string-ref", 2)
+{
+ scm_t_signed_bits i = 0;
+ ARGS2 (str, idx);
+ if (SCM_LIKELY (scm_is_string (str)
+ && SCM_I_INUMP (idx)
+ && ((i = SCM_I_INUM (idx)) >= 0)
+ && i < scm_i_string_length (str)))
+ RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, i)));
+ else
+ {
+ SYNC_REGISTER ();
+ RETURN (scm_string_ref (str, idx));
+ }
+}
+
+/* No string-set! instruction, as there is no good fast path there. */
+
+\f
/*
* Vectors and arrays
*/
- VM_DEFINE_FUNCTION (165, vector_length, "vector-length", 1)
-VM_DEFINE_FUNCTION (165, vector_ref, "vector-ref", 2)
++VM_DEFINE_FUNCTION (167, vector_length, "vector-length", 1)
+{
+ ARGS1 (vect);
+ if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
+ RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect)));
+ else
+ {
+ SYNC_REGISTER ();
+ RETURN (scm_vector_length (vect));
+ }
+}
+
- 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);
}
}
- VM_DEFINE_INSTRUCTION (167, vector_set, "vector-set", 0, 3, 0)
-VM_DEFINE_INSTRUCTION (166, 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;
NEXT;
}
- VM_DEFINE_INSTRUCTION (168, make_array, "make-array", 3, -1, 1)
-VM_DEFINE_INSTRUCTION (167, 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;
goto vm_error_not_a_struct; \
}
- VM_DEFINE_FUNCTION (169, struct_p, "struct?", 1)
-VM_DEFINE_FUNCTION (168, 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 (169, 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 (170, make_struct, "make-struct", 2, -1, 1)
++VM_DEFINE_INSTRUCTION (173, make_struct, "make-struct", 2, -1, 1)
{
unsigned h = FETCH ();
unsigned l = FETCH ();
NEXT;
}
- VM_DEFINE_FUNCTION (172, struct_ref, "struct-ref", 2)
-VM_DEFINE_FUNCTION (171, struct_ref, "struct-ref", 2)
++VM_DEFINE_FUNCTION (174, struct_ref, "struct-ref", 2)
{
ARGS2 (obj, pos);
RETURN (scm_struct_ref (obj, pos));
}
- VM_DEFINE_FUNCTION (173, struct_set, "struct-set", 3)
-VM_DEFINE_FUNCTION (172, struct_set, "struct-set", 3)
++VM_DEFINE_FUNCTION (175, struct_set, "struct-set", 3)
{
ARGS3 (obj, pos, val);
/*
* GOOPS support
*/
- VM_DEFINE_FUNCTION (174, class_of, "class-of", 1)
-VM_DEFINE_FUNCTION (173, class_of, "class-of", 1)
++VM_DEFINE_FUNCTION (176, class_of, "class-of", 1)
{
ARGS1 (obj);
if (SCM_INSTANCEP (obj))
}
/* FIXME: No checking whatsoever. */
- VM_DEFINE_FUNCTION (175, slot_ref, "slot-ref", 2)
-VM_DEFINE_FUNCTION (174, slot_ref, "slot-ref", 2)
++VM_DEFINE_FUNCTION (177, slot_ref, "slot-ref", 2)
{
size_t slot;
ARGS2 (instance, idx);
}
/* FIXME: No checking whatsoever. */
- VM_DEFINE_INSTRUCTION (176, slot_set, "slot-set", 0, 3, 0)
-VM_DEFINE_INSTRUCTION (175, 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;
/* Return true (non-zero) if PTR has suitable alignment for TYPE. */
#define ALIGNED_P(ptr, type) \
- ((scm_t_uintptr) (ptr) % alignof (type) == 0)
+ ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
- VM_DEFINE_FUNCTION (177, bv_u16_ref, "bv-u16-ref", 3)
-VM_DEFINE_FUNCTION (176, 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 (177, 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 (178, 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 (179, 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 (180, 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 (181, 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 (182, 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 (183, 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
RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
}
- VM_DEFINE_FUNCTION (185, bv_u8_ref, "bv-u8-ref", 2)
-VM_DEFINE_FUNCTION (184, 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 (185, 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 (186, 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 (187, 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 (188, 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 (189, 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 (190, 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 (191, 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 (192, 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 (193, 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
} \
}
- VM_DEFINE_INSTRUCTION (195, bv_u16_set, "bv-u16-set", 0, 4, 0)
-VM_DEFINE_INSTRUCTION (194, 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 (195, 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 (196, 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 (197, 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 (198, 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 (199, 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 (200, 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 (201, 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
NEXT; \
}
- VM_DEFINE_INSTRUCTION (203, bv_u8_set, "bv-u8-set", 0, 3, 0)
-VM_DEFINE_INSTRUCTION (202, 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 (203, 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 (204, 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 (205, 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 (206, 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 (207, 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 (208, 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 (209, 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 (210, 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 (211, 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
-/* Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001,2008,2009,2010,2011,2012 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
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));
+ }
\f
/*
* 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;
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;
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;
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;
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;
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;
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;
#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;
#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;
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;
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;
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 */
NEXT;
}
- VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
+ VM_DEFINE_INSTRUCTION (55, call, "call", 1, -1, 1)
{
nargs = FETCH ();
sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
goto vm_call;
}
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
+ else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (program))
{
SYNC_REGISTER ();
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 ();
sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
goto vm_tail_call;
}
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
+ else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (program))
{
SYNC_REGISTER ();
}
}
- 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)();
}
}
- 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)();
}
}
- 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 ();
}
}
- 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);
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, intwinds, prevwinds;
- POP2 (intwinds, vmcont);
+ SCM vmcont;
+ scm_t_ptrdiff reloc;
+ POP (vmcont);
SYNC_REGISTER ();
if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont)))
{ finish_args = vmcont;
goto vm_error_continuation_not_rewindable;
}
- prevwinds = scm_i_dynwinds ();
- vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp,
- vm_cookie);
+ reloc = vm_reinstate_partial_continuation (vm, vmcont, sp + 1 - fp, fp,
+ vm_cookie);
- /* Rewind prompt jmpbuffers, if any. */
+ /* The prompt captured a slice of the dynamic stack. Here we wind
+ those entries onto the current thread's stack.
+
+ Unhappily, this code must be here, in vm_engine, so that the setjmp
+ captures the stack in this function, and so that subsequently wound
+ stack entries don't see stale prompts. */
{
- SCM winds = scm_i_dynwinds ();
- for (; !scm_is_eq (winds, prevwinds); winds = scm_cdr (winds))
- if (SCM_PROMPT_P (scm_car (winds)) && SCM_PROMPT_SETJMP (scm_car (winds)))
- break;
+ scm_t_bits *walk;
+
+ for (walk = SCM_DYNSTACK_FIRST (SCM_VM_CONT_DATA (vmcont)->dynstack);
+ SCM_DYNSTACK_TAG (walk);
+ walk = SCM_DYNSTACK_NEXT (walk))
+ {
+ scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
+
+ scm_dynstack_wind_1 (¤t_thread->dynstack, walk);
+
+ if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT)
+ {
+ scm_t_prompt_registers *rewound;
+
+ rewound = scm_dynstack_relocate_prompt (¤t_thread->dynstack,
+ reloc, vm_cookie);
+
+ /* Reset the jmpbuf. */
+ if (SCM_I_SETJMP (rewound->regs))
+ /* Non-local exit to this newly rewound prompt. */
+ break;
+ }
+ }
}
-
+
CACHE_REGISTER ();
program = SCM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
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);
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);
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;
sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
goto vm_mv_call;
}
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
+ else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (program))
{
SYNC_REGISTER ();
NEXT;
}
- VM_DEFINE_INSTRUCTION (63, apply, "apply", 1, -1, 1)
+ VM_DEFINE_INSTRUCTION (65, apply, "apply", 1, -1, 1)
{
int len;
SCM ls;
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;
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;
+ scm_t_dynstack *dynstack;
POP (proc);
SYNC_ALL ();
- vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL, 0);
+ dynstack = scm_dynstack_capture_all (¤t_thread->dynstack);
+ vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL,
+ dynstack, 0);
cont = scm_i_make_continuation (&first, vm, vm_cont);
if (first)
{
}
}
- 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;
+ scm_t_dynstack *dynstack;
POP (proc);
SYNC_ALL ();
/* In contrast to call/cc, tail-call/cc captures the continuation without the
stack frame. */
+ dynstack = scm_dynstack_capture_all (¤t_thread->dynstack);
vm_cont = scm_i_vm_capture_stack (vp->stack_base,
SCM_FRAME_DYNAMIC_LINK (fp),
SCM_FRAME_LOWER_ADDRESS (fp) - 1,
SCM_FRAME_RETURN_ADDRESS (fp),
SCM_FRAME_MV_RETURN_ADDRESS (fp),
+ dynstack,
0);
cont = scm_i_make_continuation (&first, vm, vm_cont);
if (first)
}
}
- VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1)
+ VM_DEFINE_INSTRUCTION (69, return, "return", 0, 1, 1)
{
vm_return:
POP_CONTINUATION_HOOK (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. */
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;
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);
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;
NEXT;
}
- VM_DEFINE_INSTRUCTION (72, box, "box", 1, 1, 0)
+ VM_DEFINE_INSTRUCTION (74, box, "box", 1, 1, 0)
{
SCM val;
POP (val);
(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 (),
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);
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 ());
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 ();
/* 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 ();
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 ();
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;
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 */
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 ();
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);
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 ();
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 ();
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;
- SCM k, prompt;
+ SCM k;
+ scm_t_dynstack_prompt_flags flags;
+ scm_t_prompt_registers *regs;
escape_only_p = FETCH ();
FETCH_OFFSET (offset);
SYNC_REGISTER ();
/* Push the prompt onto the dynamic stack. */
- prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie,
- scm_i_dynwinds ());
- scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
- if (SCM_PROMPT_SETJMP (prompt))
+ regs = scm_c_make_prompt_registers (fp, sp, ip + offset, vm_cookie);
+ flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
+ scm_dynstack_push_prompt (¤t_thread->dynstack, flags, k, regs);
+ if (SCM_I_SETJMP (regs->regs))
{
/* The prompt exited nonlocally. Cache the regs back from the vp, and go
to the handler.
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);
SYNC_REGISTER ();
/* Push wind and unwind procedures onto the dynamic stack. Note that neither
are actually called; the compiler should emit calls to wind and unwind for
- the normal dynamic-wind control flow. */
- if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (wind))))
- {
- finish_args = wind;
- goto vm_error_not_a_thunk;
- }
- if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (unwind))))
- {
- finish_args = unwind;
- goto vm_error_not_a_thunk;
- }
- scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ()));
+ the normal dynamic-wind control flow. Also note that the compiler
+ should have inserted checks that they wind and unwind procs are
+ thunks, if it could not prove that to be the case. */
+ scm_dynstack_push_dynwind (¤t_thread->dynstack, wind, unwind);
NEXT;
}
- VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1)
+ VM_DEFINE_INSTRUCTION (89, abort, "abort", 1, -1, -1)
{
unsigned n = FETCH ();
SYNC_REGISTER ();
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. */
- scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+ scm_dynstack_pop (¤t_thread->dynstack);
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 ();
- SCM wf;
SYNC_REGISTER ();
sp -= 2 * n;
CHECK_UNDERFLOW ();
- wf = scm_i_make_with_fluids (n, sp + 1, sp + 1 + n);
+ scm_dynstack_push_fluids (¤t_thread->dynstack, n, sp + 1, sp + 1 + n,
+ current_thread->dynamic_state);
NULLSTACK (2 * n);
-
- scm_i_swap_with_fluids (wf, current_thread->dynamic_state);
- scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
NEXT;
}
- VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0)
+ VM_DEFINE_INSTRUCTION (92, unwind_fluids, "unwind-fluids", 0, 0, 0)
{
- SCM wf;
- wf = scm_car (scm_i_dynwinds ());
- scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
- scm_i_swap_with_fluids (wf, current_thread->dynamic_state);
+ /* This function must not allocate. */
+ scm_dynstack_unwind_fluids (¤t_thread->dynstack,
+ current_thread->dynamic_state);
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;
else
{
SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
+ if (scm_is_eq (val, SCM_UNDEFINED))
+ val = SCM_I_FLUID_DEFAULT (*sp);
if (SCM_UNLIKELY (scm_is_eq (val, SCM_UNDEFINED)))
{
finish_args = *sp;
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;
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;
NEXT;
}
-
/*
(defun renumber-ops ()
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
## Process this file with automake to produce Makefile.in.
##
-## Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+## Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
.PHONY: ice-9/psyntax-pp.scm.gen
+# Keep this rule in sync with that in `am/guilec'.
ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
- $(AM_V_GUILEC) GUILE_AUTO_COMPILE=0 \
+ $(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" \
-o "ice-9/psyntax-pp.go" "$(srcdir)/ice-9/psyntax.scm"
SCHEME_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 \
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 = \
ice-9/weak-vector.scm \
ice-9/list.scm \
ice-9/serialize.scm \
- ice-9/vlist.scm
+ ice-9/vlist.scm \
+ ice-9/local-eval.scm
SRFI_SOURCES = \
srfi/srfi-1.scm \
EXTRA_DIST += oop/ChangeLog-2008
+ ELISP_SOURCES = \
+ language/elisp/boot.el
+
NOCOMP_SOURCES = \
ice-9/match.upstream.scm \
ice-9/psyntax.scm \
;;; Guile VM code converters
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2012 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
(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))))
(list "`~a'~@[ (arg)~]"
(binding:name b) (< (binding:index b) nargs))
(lp (cdr bindings))))))))
+ ((assert-nargs-ee/locals assert-nargs-ge/locals)
+ (list "~a arg~:p, ~a local~:p"
+ (logand (car args) #x7) (ash (car args) -3)))
((free-ref free-boxed-ref free-boxed-set)
;; FIXME: we can do better than this
(list "(closure variable)"))
;;; Guile Emacs Lisp
-;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011 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
#:use-module (srfi srfi-26)
#:export (compile-tree-il
compile-progn
+ compile-eval-when-compile
compile-if
compile-defconst
compile-defvar
compile-setq
compile-let
- compile-lexical-let
compile-flet
+ compile-labels
compile-let*
- compile-lexical-let*
- compile-flet*
- compile-without-void-checks
- compile-with-always-lexical
compile-guile-ref
compile-guile-primitive
- compile-while
compile-function
compile-defmacro
compile-defun
#{compile-`}#
- compile-quote))
+ compile-quote
+ compile-%funcall
+ compile-%set-lexical-binding-mode))
;;; Certain common parameters (like the bindings data structure or
;;; compiler options) are not always passed around but accessed using
(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))
+ (define lexical-binding (make-fluid))
;;; Find the source properties of some parsed expression if there are
;;; any associated with it.
;;; Build a call to a primitive procedure nicely.
(define (call-primitive loc sym . args)
- (make-application loc (make-primitive-ref loc sym) args))
+ (make-primcall 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-primcall 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-call loc
- (make-module-ref loc runtime 'ensure-fluid! #t)
- (list (make-const loc module)
- (make-const loc sym))))
-
- (define (ensuring-globals loc bindings body)
- (list->seq
- loc
- `(,@(map-globals-needed (fluid-ref bindings)
- (lambda (mod sym)
- (generate-ensure-global loc sym mod)))
- ,body)))
-
- ;;; Build a construct that establishes dynamic bindings for certain
- ;;; variables. We may want to choose between binding with fluids and
- ;;; with-fluids* and using just ordinary module symbols and
- ;;; setting/reverting their values with a dynamic-wind.
-
- (define (let-dynamic loc syms module vals body)
- (call-primitive
- loc
- 'with-fluids*
- (make-primcall loc 'list
- (map (lambda (sym)
- (make-module-ref loc module sym #t))
- syms))
- (make-primcall loc 'list vals)
- (make-lambda loc
- '()
- (make-lambda-case #f '() #f #f #f '() '() body #f))))
-
- ;;; Handle access to a variable (reference/setting) correctly depending
- ;;; on whether it is currently lexically or dynamically bound. lexical
- ;;; access is done only for references to the value-slot module!
-
- (define (access-variable loc
- sym
- module
- handle-global
- handle-lexical
- handle-dynamic)
- (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
- (cond
- (lexical (handle-lexical lexical))
- ((equal? module function-slot) (handle-global))
- (else (handle-dynamic)))))
-
- ;;; Generate code to reference a variable. For references in the
- ;;; value-slot module, we may want to generate a lexical reference
- ;;; instead if the variable has a lexical binding.
+ (define (access-variable loc symbol handle-lexical handle-dynamic)
+ (cond
+ ((get-lexical-binding (fluid-ref bindings-data) symbol)
+ => handle-lexical)
+ (else
+ (handle-dynamic))))
- (define (reference-variable loc sym module)
+ (define (reference-variable loc symbol)
(access-variable
loc
- sym
- module
- (lambda () (make-module-ref loc module sym #t))
- (lambda (lexical) (make-lexical-ref loc lexical lexical))
+ symbol
+ (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)))))
+ (make-module-ref loc value-slot symbol #t)))))
+
+ (define (global? module symbol)
+ (module-variable module symbol))
+
+ (define (ensure-globals! loc names body)
+ (if (and (every (cut global? (resolve-module value-slot) <>) names)
+ (every symbol-interned? names))
+ body
- (make-sequence
++ (list->seq
+ loc
+ `(,@(map
+ (lambda (name)
+ (ensure-fluid! value-slot name)
- (make-application loc
- (make-module-ref loc runtime 'ensure-fluid! #t)
- (list (make-const loc value-slot)
- (make-const loc name))))
++ (make-call loc
++ (make-module-ref loc runtime 'ensure-fluid! #t)
++ (list (make-const loc value-slot)
++ (make-const loc name))))
+ names)
+ ,body))))
+
+ (define (set-variable! loc symbol value)
+ (access-variable
+ loc
+ symbol
+ (lambda (lexical)
+ (make-lexical-set loc lexical lexical value))
+ (lambda ()
+ (ensure-globals!
+ loc
+ (list symbol)
+ (call-primitive loc
+ 'fluid-set!
+ (make-module-ref loc value-slot symbol #t)
+ value)))))
- ;;; 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 (access-function loc symbol handle-lexical handle-global)
+ (cond
+ ((get-function-binding (fluid-ref bindings-data) symbol)
+ => handle-lexical)
+ (else
+ (handle-global))))
- (define (set-variable! loc sym module value)
- (access-variable
+ (define (reference-function loc symbol)
+ (access-function
+ loc
+ symbol
+ (lambda (gensym) (make-lexical-ref loc symbol gensym))
+ (lambda () (make-module-ref loc function-slot symbol #t))))
+
+ (define (set-function! loc symbol value)
+ (access-function
loc
- sym
- module
+ symbol
+ (lambda (gensym) (make-lexical-set loc symbol gensym value))
(lambda ()
- (make-application
+ (make-call
loc
- (make-module-ref loc runtime 'set-variable! #t)
- (list (make-const loc module) (make-const loc sym) value)))
- (lambda (lexical) (make-lexical-set loc lexical lexical value))
- (lambda ()
- (mark-global-needed! (fluid-ref bindings-data) sym module)
- (call-primitive loc
- 'fluid-set!
- (make-module-ref loc module sym #t)
- value))))
-
- ;;; Process the bindings part of a let or let* expression; that is,
- ;;; check for correctness and bring it to the form ((sym1 . val1) (sym2
- ;;; . val2) ...).
-
- (define (process-let-bindings loc bindings)
- (map
- (lambda (b)
- (if (symbol? b)
- (cons b 'nil)
- (if (or (not (list? b))
- (not (= (length b) 2)))
- (report-error
- loc
- "expected symbol or list of 2 elements in let")
- (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 is always lexical, OR we're processing a function-slot
- ;;; binding.
-
- (define (bind-lexically? sym module)
- (or (eq? module 'lexical)
- (eq? module function-slot)
- (and (equal? module value-slot)
- (let ((always (fluid-ref always-lexical)))
- (or (eq? always 'all)
- (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 ()
- (list->seq 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)
- (list->seq 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. One thing we have to be aware of is
- ;;; that lambda arguments are usually dynamically bound, even when a
- ;;; lexical binding is intact for a symbol. For symbols that are marked
- ;;; as 'always lexical,' however, we lexically bind here as well, and
- ;;; thus we get them out of the let-dynamic call and register a lexical
- ;;; binding for them (the lexical target variable is already there,
- ;;; namely the real lambda argument from TreeIL).
-
- (define (compile-lambda loc args body)
- (if (not (list? args))
- (report-error loc "expected list for argument-list" args))
- (if (null? body)
- (report-error loc "function body must not be empty"))
- (receive (required optional rest lexical dynamic)
- (split-lambda-arguments loc args)
- (define (process-args args)
- (define (find-pairs pairs filter)
- (lset-intersection (lambda (name+sym x)
- (eq? (car name+sym) x))
- pairs
- filter))
- (let* ((syms (map (lambda (x) (gensym)) args))
- (pairs (map cons args syms))
- (lexical-pairs (find-pairs pairs lexical))
- (dynamic-pairs (find-pairs pairs dynamic)))
- (values syms pairs lexical-pairs dynamic-pairs)))
- (let*-values (((required-syms
- required-pairs
- required-lex-pairs
- required-dyn-pairs)
- (process-args required))
- ((optional-syms
- optional-pairs
- optional-lex-pairs
- optional-dyn-pairs)
- (process-args optional))
- ((rest-syms rest-pairs rest-lex-pairs rest-dyn-pairs)
- (process-args (if rest (list rest) '())))
- ((the-rest-sym) (if rest (car rest-syms) #f))
- ((all-syms) (append required-syms
- optional-syms
- rest-syms))
- ((all-lex-pairs) (append required-lex-pairs
- optional-lex-pairs
- rest-lex-pairs))
- ((all-dyn-pairs) (append required-dyn-pairs
- optional-dyn-pairs
- rest-dyn-pairs)))
- (for-each (lambda (sym)
- (mark-global-needed! (fluid-ref bindings-data)
- sym
- value-slot))
- dynamic)
- (with-dynamic-bindings
- (fluid-ref bindings-data)
- dynamic
- (lambda ()
- (with-lexical-bindings
- (fluid-ref bindings-data)
- (map car all-lex-pairs)
- (map cdr all-lex-pairs)
- (lambda ()
- (make-lambda
- loc
- '()
- (make-lambda-case
- #f
- required
- optional
- rest
- #f
- (map (lambda (x) (nil-value loc)) optional)
- all-syms
- (let ((compiled-body
- (list->seq loc (map compile-expr body))))
- (make-seq
- loc
- (if rest
- (make-conditional
- loc
- (call-primitive loc
- 'null?
- (make-lexical-ref loc
- rest
- the-rest-sym))
- (make-lexical-set loc
- rest
- the-rest-sym
- (nil-value loc))
- (make-void loc))
- (make-void loc))
- (if (null? dynamic)
- compiled-body
- (let-dynamic loc
- dynamic
- value-slot
- (map (lambda (name-sym)
- (make-lexical-ref
- loc
- (car name-sym)
- (cdr name-sym)))
- all-dyn-pairs)
- compiled-body))))
- #f)))))))))
+ (make-module-ref loc runtime 'set-symbol-function! #t)
+ (list (make-const loc symbol) value)))))
+
+ (define (bind-lexically? sym module decls)
+ (or (eq? module function-slot)
+ (let ((decl (assq-ref decls sym)))
+ (and (equal? module value-slot)
+ (or
+ (eq? decl 'lexical)
+ (and
+ (fluid-ref lexical-binding)
+ (not (global? (resolve-module module) sym))))))))
+
+ (define (parse-let-binding loc binding)
+ (pmatch binding
+ ((unquote var)
+ (guard (symbol? var))
+ (cons var #nil))
+ ((,var)
+ (guard (symbol? var))
+ (cons var #nil))
+ ((,var ,val)
+ (guard (symbol? var))
+ (cons var val))
+ (else
+ (report-error loc "malformed variable binding" binding))))
+
+ (define (parse-flet-binding loc binding)
+ (pmatch binding
+ ((,var ,args . ,body)
+ (guard (symbol? var))
+ (cons var `(function (lambda ,args ,@body))))
+ (else
+ (report-error loc "malformed function binding" binding))))
+
+ (define (parse-declaration expr)
+ (pmatch expr
+ ((lexical . ,vars)
+ (map (cut cons <> 'lexical) vars))
+ (else
+ '())))
+
+ (define (parse-body-1 body lambda?)
+ (let loop ((lst body)
+ (decls '())
+ (intspec #f)
+ (doc #f))
+ (pmatch lst
+ (((declare . ,x) . ,tail)
+ (loop tail (append-reverse x decls) intspec doc))
+ (((interactive . ,x) . ,tail)
+ (guard lambda? (not intspec))
+ (loop tail decls x doc))
+ ((,x . ,tail)
+ (guard lambda? (string? x) (not doc) (not (null? tail)))
+ (loop tail decls intspec x))
+ (else
+ (values (append-map parse-declaration decls)
+ intspec
+ doc
+ lst)))))
+
+ (define (parse-lambda-body body)
+ (parse-body-1 body #t))
+
+ (define (parse-body body)
+ (receive (decls intspec doc body) (parse-body-1 body #f)
+ (values decls body)))
+
+ ;;; Partition the argument list of a lambda expression into required,
+ ;;; optional and rest arguments.
+
+ (define (parse-lambda-list lst)
+ (define (%match lst null optional rest symbol)
+ (pmatch lst
+ (() (null))
+ ((&optional . ,tail) (optional tail))
+ ((&rest . ,tail) (rest tail))
+ ((,arg . ,tail) (guard (symbol? arg)) (symbol arg tail))
+ (else (fail))))
+ (define (return rreq ropt rest)
+ (values #t (reverse rreq) (reverse ropt) rest))
+ (define (fail)
+ (values #f #f #f #f))
+ (define (parse-req lst rreq)
+ (%match lst
+ (lambda () (return rreq '() #f))
+ (lambda (tail) (parse-opt tail rreq '()))
+ (lambda (tail) (parse-rest tail rreq '()))
+ (lambda (arg tail) (parse-req tail (cons arg rreq)))))
+ (define (parse-opt lst rreq ropt)
+ (%match lst
+ (lambda () (return rreq ropt #f))
+ (lambda (tail) (fail))
+ (lambda (tail) (parse-rest tail rreq ropt))
+ (lambda (arg tail) (parse-opt tail rreq (cons arg ropt)))))
+ (define (parse-rest lst rreq ropt)
+ (%match lst
+ (lambda () (fail))
+ (lambda (tail) (fail))
+ (lambda (tail) (fail))
+ (lambda (arg tail) (parse-post-rest tail rreq ropt arg))))
+ (define (parse-post-rest lst rreq ropt rest)
+ (%match lst
+ (lambda () (return rreq ropt rest))
+ (lambda () (fail))
+ (lambda () (fail))
+ (lambda (arg tail) (fail))))
+ (parse-req lst '()))
+
+ (define (make-simple-lambda loc meta req opt init rest vars body)
+ (make-lambda loc
+ meta
+ (make-lambda-case #f req opt rest #f init vars body #f)))
+
+ (define (compile-lambda loc meta args body)
+ (receive (valid? req-ids opt-ids rest-id)
+ (parse-lambda-list args)
+ (if valid?
+ (let* ((all-ids (append req-ids
+ opt-ids
+ (or (and=> rest-id list) '())))
+ (all-vars (map (lambda (ignore) (gensym)) all-ids)))
+ (let*-values (((decls intspec doc forms)
+ (parse-lambda-body body))
+ ((lexical dynamic)
+ (partition
+ (compose (cut bind-lexically? <> value-slot decls)
+ car)
+ (map list all-ids all-vars)))
+ ((lexical-ids lexical-vars) (unzip2 lexical))
+ ((dynamic-ids dynamic-vars) (unzip2 dynamic)))
+ (with-dynamic-bindings
+ (fluid-ref bindings-data)
+ dynamic-ids
+ (lambda ()
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ lexical-ids
+ lexical-vars
+ (lambda ()
+ (ensure-globals!
+ loc
+ dynamic-ids
+ (let* ((tree-il (compile-expr `(progn ,@forms)))
+ (full-body
+ (if (null? dynamic)
+ tree-il
+ (make-dynlet
+ loc
+ (map (cut make-module-ref loc value-slot <> #t)
+ dynamic-ids)
+ (map (cut make-lexical-ref loc <> <>)
+ dynamic-ids
+ dynamic-vars)
+ tree-il))))
+ (make-simple-lambda loc
+ meta
+ req-ids
+ opt-ids
+ (map (const (nil-value loc))
+ opt-ids)
+ rest-id
+ all-vars
+ full-body)))))))))
+ (report-error "invalid function" `(lambda ,args ,@body)))))
;;; 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
;;; Handle macro and special operator bindings.
- (define (find-operator sym type)
+ (define (find-operator name type)
(and
- (symbol? sym)
- (module-defined? (resolve-interface function-slot) sym)
- (let* ((op (module-ref (resolve-module function-slot) sym))
- (op (if (fluid? op) (fluid-ref op) op)))
+ (symbol? name)
+ (module-defined? (resolve-interface function-slot) name)
+ (let ((op (module-ref (resolve-module function-slot) name)))
(if (and (pair? op) (eq? (car op) type))
(cdr op)
#f))))
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 ()
- (list->seq 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))))))
-
;;; Special operators
(defspecial progn (loc args)
- (list->seq loc (map compile-expr args)))
- (make-sequence loc
- (if (null? args)
- (list (nil-value loc))
- (map compile-expr args))))
++ (list->seq loc
++ (if (null? args)
++ (list (nil-value loc))
++ (map compile-expr args))))
+
+ (defspecial eval-when-compile (loc args)
+ (make-const loc (compile `(progn ,@args) #:from 'elisp #:to 'value)))
(defspecial if (loc args)
(pmatch args
((,cond ,then . ,else)
- (make-conditional loc
- (compile-expr cond)
- (compile-expr then)
- (if (null? else)
- (nil-value loc)
- (list->seq loc (map compile-expr else)))))))
+ (make-conditional
+ loc
+ (call-primitive loc 'not
+ (call-primitive loc 'nil? (compile-expr cond)))
+ (compile-expr then)
+ (compile-expr `(progn ,@else))))))
(defspecial defconst (loc args)
(pmatch args
((,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
- (make-sequence loc
- (list (set-variable! loc sym (compile-expr value))
- (make-const loc sym)))))))
+ (make-seq loc
- (set-variable! loc
- sym
- value-slot
- (compile-expr value))
- (make-const loc sym))))))
++ (set-variable! loc sym (compile-expr value))
++ (make-const loc sym))))))
(defspecial defvar (loc args)
(pmatch args
((,sym) (make-const loc sym))
((,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
- (make-sequence
+ (make-seq
loc
- (list
+ (make-conditional
+ loc
(make-conditional
loc
- (make-conditional
+ (call-primitive
loc
- (call-primitive
- loc
- 'module-bound?
- (call-primitive loc
- 'resolve-interface
- (make-const loc value-slot))
- (make-const loc sym))
+ 'module-bound?
(call-primitive loc
- 'fluid-bound?
- (make-module-ref loc value-slot sym #t))
- (make-const loc #f))
- (make-void loc)
- (set-variable! loc sym (compile-expr value)))
- (make-const loc sym)))))))
+ 'resolve-interface
+ (make-const loc value-slot))
+ (make-const loc sym))
+ (call-primitive loc
+ 'fluid-bound?
+ (make-module-ref loc value-slot sym #t))
+ (make-const loc #f))
+ (make-void loc)
- (set-variable! loc sym value-slot (compile-expr value)))
++ (set-variable! loc sym (compile-expr value)))
+ (make-const loc sym))))))
(defspecial setq (loc args)
(define (car* x) (if (null? x) '() (car x)))
(define (cdr* x) (if (null? x) '() (cdr x)))
(define (cadr* x) (car* (cdr* x)))
(define (cddr* x) (cdr* (cdr* x)))
- (make-sequence
+ (list->seq
loc
(let loop ((args args) (last (nil-value loc)))
(if (null? args)
(if (not (symbol? sym))
(report-error loc "expected symbol in setq")
(cons
- (set-variable! loc sym value-slot val)
+ (set-variable! loc sym val)
(loop (cddr* args)
- (reference-variable loc sym value-slot)))))))))
+ (reference-variable loc sym)))))))))
(defspecial let (loc args)
(pmatch args
- ((,bindings . ,body)
- (generate-let loc value-slot bindings body))))
-
- (defspecial lexical-let (loc args)
- (pmatch args
- ((,bindings . ,body)
- (generate-let loc 'lexical bindings body))))
-
- (defspecial flet (loc args)
- (pmatch args
- ((,bindings . ,body)
- (generate-let loc function-slot bindings body))))
+ ((,varlist . ,body)
+ (let ((bindings (map (cut parse-let-binding loc <>) varlist)))
+ (receive (decls forms) (parse-body body)
+ (receive (lexical dynamic)
+ (partition
+ (compose (cut bind-lexically? <> value-slot decls)
+ car)
+ bindings)
+ (let ((make-values (lambda (for)
+ (map (lambda (el) (compile-expr (cdr el)))
+ for)))
+ (make-body (lambda () (compile-expr `(progn ,@forms)))))
+ (ensure-globals!
+ loc
+ (map car dynamic)
+ (if (null? lexical)
+ (make-dynlet loc
+ (map (compose (cut make-module-ref
+ loc
+ value-slot
+ <>
+ #t)
+ car)
+ dynamic)
+ (map (compose compile-expr cdr)
+ 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)
+ (make-dynlet loc
+ (map
+ (compose
+ (cut make-module-ref
+ loc
+ value-slot
+ <>
+ #t)
+ car)
+ dynamic)
+ (map
+ (lambda (sym)
+ (make-lexical-ref
+ loc
+ sym
+ sym))
+ dynamic-syms)
+ (make-body))))))))))))))))
(defspecial let* (loc args)
(pmatch args
- ((,bindings . ,body)
- (generate-let* loc value-slot bindings body))))
+ ((,varlist . ,body)
+ (let ((bindings (map (cut parse-let-binding loc <>) varlist)))
+ (receive (decls forms) (parse-body body)
+ (let iterate ((tail bindings))
+ (if (null? tail)
+ (compile-expr `(progn ,@forms))
+ (let ((sym (caar tail))
+ (value (compile-expr (cdar tail))))
+ (if (bind-lexically? sym value-slot decls)
+ (let ((target (gensym)))
+ (make-let loc
+ `(,target)
+ `(,target)
+ `(,value)
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ `(,sym)
+ `(,target)
+ (lambda () (iterate (cdr tail))))))
+ (ensure-globals!
+ loc
+ (list sym)
+ (make-dynlet loc
+ (list (make-module-ref loc value-slot sym #t))
+ (list value)
+ (iterate (cdr tail)))))))))))))
- (defspecial lexical-let* (loc args)
+ (defspecial flet (loc args)
(pmatch args
((,bindings . ,body)
- (generate-let* loc 'lexical bindings body))))
-
- (defspecial flet* (loc args)
+ (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
+ (receive (decls forms) (parse-body body)
+ (let ((names (map car names+vals))
+ (vals (map cdr names+vals))
+ (gensyms (map (lambda (x) (gensym)) names+vals)))
+ (with-function-bindings
+ (fluid-ref bindings-data)
+ names
+ gensyms
+ (lambda ()
+ (make-let loc
+ names
+ gensyms
+ (map compile-expr vals)
+ (compile-expr `(progn ,@forms)))))))))))
+
+ (defspecial labels (loc args)
(pmatch args
((,bindings . ,body)
- (generate-let* loc function-slot bindings body))))
-
- ;;; Temporarily set symbols as always lexical only for the lexical scope
- ;;; of a construct.
-
- (defspecial with-always-lexical (loc args)
- (pmatch args
- ((,syms . ,body)
- (with-added-symbols loc always-lexical syms body))))
+ (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
+ (receive (decls forms) (parse-body body)
+ (let ((names (map car names+vals))
+ (vals (map cdr names+vals))
+ (gensyms (map (lambda (x) (gensym)) names+vals)))
+ (with-function-bindings
+ (fluid-ref bindings-data)
+ names
+ gensyms
+ (lambda ()
+ (make-letrec #f
+ loc
+ names
+ gensyms
+ (map compile-expr vals)
+ (compile-expr `(progn ,@forms)))))))))))
;;; guile-ref allows building TreeIL's module references from within
;;; elisp as a way to access data within the Guile universe. The module
((,sym)
(make-primitive-ref loc sym))))
- ;;; A while construct is transformed into a tail-recursive loop like
- ;;; this:
- ;;;
- ;;; (letrec ((iterate (lambda ()
- ;;; (if condition
- ;;; (begin body
- ;;; (iterate))
- ;;; #nil))))
- ;;; (iterate))
- ;;;
- ;;; As letrec is not directly accessible from elisp, while is
- ;;; implemented here instead of with a macro.
-
- (defspecial while (loc args)
- (pmatch args
- ((,condition . ,body)
- (let* ((itersym (gensym))
- (compiled-body (map compile-expr body))
- (iter-call (make-call loc
- (make-lexical-ref loc
- 'iterate
- itersym)
- (list)))
- (full-body (list->seq 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
- '()
- '()
- lambda-body
- #f))))
- (make-letrec loc
- #f
- '(iterate)
- (list itersym)
- (list iter-thunk)
- iter-call)))))
-
(defspecial function (loc args)
(pmatch args
(((lambda ,args . ,body))
- (compile-lambda loc args body))
+ (compile-lambda loc '() args body))
((,sym) (guard (symbol? sym))
- (reference-variable loc sym function-slot))))
+ (reference-function loc sym))))
(defspecial defmacro (loc args)
(pmatch args
(if (not (symbol? name))
(report-error loc "expected symbol as macro name" name)
(let* ((tree-il
- (make-sequence
+ (make-seq
loc
- (set-variable!
- (list
- (set-function!
++ (set-function!
+ loc
+ name
- function-slot
- (make-primcall loc 'cons
- (list (make-const loc 'macro)
- (compile-lambda loc args body))))
++ (make-call
+ loc
- name
- (make-application
- loc
- (make-module-ref loc '(guile) 'cons #t)
- (list (make-const loc 'macro)
- (compile-lambda loc
- `((name . ,name))
- args
- body))))
- (make-const loc name)))))
++ (make-module-ref loc '(guile) 'cons #t)
++ (list (make-const loc 'macro)
++ (compile-lambda loc
++ `((name . ,name))
++ args
++ body))))
+ (make-const loc name))))
- (compile (ensuring-globals loc bindings-data tree-il)
- #:from 'tree-il
- #:to 'value)
+ (compile tree-il #:from 'tree-il #:to 'value)
tree-il)))))
(defspecial defun (loc args)
((,name ,args . ,body)
(if (not (symbol? name))
(report-error loc "expected symbol as function name" name)
- (make-sequence loc
- (list (set-function! loc
- name
- (compile-lambda loc
- `((name . ,name))
- args
- body))
- (make-const loc name)))))))
+ (make-seq loc
- (set-variable! loc
++ (set-function! loc
+ name
- function-slot
+ (compile-lambda loc
++ `((name . ,name))
+ args
+ body))
+ (make-const loc name))))))
(defspecial #{`}# (loc args)
(pmatch args
((,val)
(make-const loc val))))
- (make-application loc
- (compile-expr function)
- (map compile-expr arguments)))))
+ (defspecial %funcall (loc args)
+ (pmatch args
+ ((,function . ,arguments)
++ (make-call loc
++ (compile-expr function)
++ (map compile-expr arguments)))))
+
+ (defspecial %set-lexical-binding-mode (loc args)
+ (pmatch args
+ ((,val)
+ (fluid-set! lexical-binding val)
+ (make-void loc))))
+
;;; Compile a compound expression to Tree-IL.
(define (compile-pair loc expr)
=> (lambda (macro-function)
(compile-expr (apply macro-function arguments))))
(else
- (make-call loc
- (if (symbol? operator)
- (reference-variable loc
- operator
- function-slot)
- (compile-expr operator))
- (map compile-expr arguments))))))
+ (compile-expr `(%funcall (function ,operator) ,@arguments))))))
;;; Compile a symbol expression. This is a variable reference or maybe
;;; some special value like nil.
(case sym
((nil) (nil-value loc))
((t) (t-value loc))
- (else (reference-variable loc sym value-slot))))
+ (else (reference-variable loc sym))))
;;; Compile a single expression to TreeIL.
(case key
((#:warnings) ; ignore
#f)
- ((#:always-lexical)
- (if (valid-symbol-list-arg? value)
- (fluid-set! always-lexical value)
- (report-error #f
- "Invalid value for #:always-lexical"
- value)))
(else (report-error #f
"Invalid compiler option"
key)))))))
- ;;; Entry point for compilation to TreeIL. This creates the bindings
- ;;; data structure, and after compiling the main expression we need to
- ;;; make sure all globals for symbols used during the compilation are
- ;;; created using the generate-ensure-global function.
-
(define (compile-tree-il expr env opts)
(values
- (with-fluids ((bindings-data (make-bindings))
- (disable-void-check '())
- (always-lexical '()))
+ (with-fluids ((bindings-data (make-bindings)))
(process-options! opts)
- (let ((compiled (compile-expr expr)))
- (ensuring-globals (location expr) bindings-data compiled)))
+ (compile-expr expr))
env
env))
;;; Guile Emacs Lisp
-;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2009, 2010, 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
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.
(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
(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 (set-symbol-function! symbol value)
+ (let ((module (resolve-module function-slot-module)))
+ (module-define! module symbol value)
+ (module-export! module (list symbol)))
+ value)
- (define-syntax built-in-func
- (syntax-rules ()
- ((_ name value)
- (begin
- (define-public name 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
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 ...))))))))
;;; TREE-IL -> GLIL compiler
-;; Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001,2008,2009,2010,2011,2012 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
((list? . 1) . list?)
((symbol? . 1) . symbol?)
((vector? . 1) . vector?)
+ ((nil? . 1) . nil?)
(list . list)
(vector . vector)
((class-of . 1) . class-of)
((@slot-ref . 2) . slot-ref)
((@slot-set! . 3) . slot-set)
+ ((string-length . 1) . string-length)
+ ((string-ref . 2) . string-ref)
+ ((vector-length . 1) . vector-length)
((vector-ref . 2) . vector-ref)
((vector-set! . 3) . vector-set)
((variable-ref . 1) . variable-ref)
(emit-code src (make-glil-const exp))))
(maybe-emit-return))
- ;; FIXME: should represent sequence as exps tail
- ((<sequence> exps)
- (let lp ((exps exps))
- (if (null? (cdr exps))
- (comp-tail (car exps))
- (begin
- (comp-drop (car exps))
- (lp (cdr exps))))))
-
- ((<application> src proc args)
- ;; FIXME: need a better pattern-matcher here
+ ((<seq> head tail)
+ (comp-drop head)
+ (comp-tail tail))
+
+ ((<call> src proc args)
(cond
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@apply)
- (>= (length args) 1))
- (let ((proc (car args))
- (args (cdr args)))
- (cond
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
- (not (eq? context 'push)) (not (eq? context 'vals)))
- ;; tail: (lambda () (apply values '(1 2)))
- ;; drop: (lambda () (apply values '(1 2)) 3)
- ;; push: (lambda () (list (apply values '(10 12)) 1))
- (case context
- ((drop) (for-each comp-drop args) (maybe-emit-return))
- ((tail)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'return/values* (length args))))))
-
- (else
- (case context
- ((tail)
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
- ((push)
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'apply (1+ (length args))))
- (maybe-emit-return))
- ((vals)
- (comp-vals
- (make-application src (make-primitive-ref #f 'apply)
- (cons proc args))
- MVRA)
- (maybe-emit-return))
- ((drop)
- ;; Well, shit. The proc might return any number of
- ;; values (including 0), since it's in a drop context,
- ;; yet apply does not create a MV continuation. So we
- ;; mv-call out to our trampoline instead.
- (comp-drop
- (make-application src (make-primitive-ref #f 'apply)
- (cons proc args)))
- (maybe-emit-return)))))))
-
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values))
- ;; tail: (lambda () (values '(1 2)))
- ;; drop: (lambda () (values '(1 2)) 3)
- ;; push: (lambda () (list (values '(10 12)) 1))
- ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
- (case context
- ((drop) (for-each comp-drop args) (maybe-emit-return))
- ((push)
- (case (length args)
- ((0)
- ;; FIXME: This is surely an error. We need to add a
- ;; values-mismatch warning pass.
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push proc)
- (emit-code src (make-glil-call 'call 0))
- (maybe-emit-return))
- ((1)
- (comp-push (car args)))
- (else
- ;; Taking advantage of unspecified order of evaluation of
- ;; arguments.
- (for-each comp-drop (cdr args))
- (comp-push (car args)))))
- ((vals)
- (for-each comp-push args)
- (emit-code #f (make-glil-const (length args)))
- (emit-branch src 'br MVRA))
- ((tail)
- (for-each comp-push args)
- (emit-code src (let ((len (length args)))
- (if (= len 1)
- (make-glil-call 'return 1)
- (make-glil-call 'return/values len)))))))
-
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-values)
- (= (length args) 2))
- ;; CONSUMER
- ;; PRODUCER
- ;; (mv-call MV)
- ;; ([tail]-call 1)
- ;; goto POST
- ;; MV: [tail-]call/nargs
- ;; POST: (maybe-drop)
- (case context
- ((vals)
- ;; Fall back.
- (comp-vals
- (make-application src (make-primitive-ref #f 'call-with-values)
- args)
- MVRA)
- (maybe-emit-return))
- (else
- (let ((MV (make-label)) (POST (make-label))
- (producer (car args)) (consumer (cadr args)))
- (if (not (eq? context 'tail))
- (emit-code src (make-glil-call 'new-frame 0)))
- (comp-push consumer)
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push producer)
- (emit-code src (make-glil-mv-call 0 MV))
- (case context
- ((tail) (emit-code src (make-glil-call 'tail-call 1)))
- (else (emit-code src (make-glil-call 'call 1))
- (emit-branch #f 'br POST)))
- (emit-label MV)
- (case context
- ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
- (else (emit-code src (make-glil-call 'call/nargs 0))
- (emit-label POST)
- (if (eq? context 'drop)
- (emit-code #f (make-glil-call 'drop 1)))
- (maybe-emit-return)))))))
-
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-current-continuation)
- (= (length args) 1))
- (case context
- ((tail)
- (comp-push (car args))
- (emit-code src (make-glil-call 'tail-call/cc 1)))
- ((vals)
- (comp-vals
- (make-application
- src (make-primitive-ref #f 'call-with-current-continuation)
- args)
- MVRA)
- (maybe-emit-return))
- ((push)
- (comp-push (car args))
- (emit-code src (make-glil-call 'call/cc 1))
- (maybe-emit-return))
- ((drop)
- ;; Crap. Just like `apply' in drop context.
- (comp-drop
- (make-application
- src (make-primitive-ref #f 'call-with-current-continuation)
- args))
- (maybe-emit-return))))
-
- ;; A hack for variable-set, the opcode for which takes its args
- ;; reversed, relative to the variable-set! function
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) 'variable-set!)
- (= (length args) 2))
- (comp-push (cadr args))
- (comp-push (car args))
- (emit-code src (make-glil-call 'variable-set 2))
- (case context
- ((tail push vals) (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ((and (primitive-ref? proc)
- (or (hash-ref *primcall-ops*
- (cons (primitive-ref-name proc) (length args)))
- (hash-ref *primcall-ops* (primitive-ref-name proc))))
- => (lambda (op)
- (for-each comp-push args)
- (emit-code src (make-glil-call op (length args)))
- (case (instruction-pushes op)
- ((0)
- (case context
- ((tail push vals) (emit-code #f (make-glil-void))))
- (maybe-emit-return))
- ((1)
- (case context
- ((drop) (emit-code #f (make-glil-call 'drop 1))))
- (maybe-emit-return))
- ((-1)
- ;; A control instruction, like return/values. Here we
- ;; just have to hope that the author of the tree-il
- ;; knew what they were doing.
- *unspecified*)
- (else
- (error "bad primitive op: too many pushes"
- op (instruction-pushes op))))))
-
;; call to the same lambda-case in tail position
((and (lexical-ref? proc)
self-label (eq? (lexical-ref-gensym proc) self-label)
(emit-branch #f 'br RA)
(emit-label POST)))))))))
+ ((<primcall> src name args)
+ (pmatch (cons name args)
+ ((@apply ,proc . ,args)
+ (cond
+ ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+ (not (eq? context 'push)) (not (eq? context 'vals)))
+ ;; tail: (lambda () (apply values '(1 2)))
+ ;; drop: (lambda () (apply values '(1 2)) 3)
+ ;; push: (lambda () (list (apply values '(10 12)) 1))
+ (case context
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'return/values* (length args))))))
+
+ (else
+ (case context
+ ((tail)
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
+ ((push)
+ (emit-code src (make-glil-call 'new-frame 0))
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'apply (1+ (length args))))
+ (maybe-emit-return))
+ (else
+ (comp-tail (make-primcall src 'apply (cons proc args))))))))
+
+ ((values . _)
+ ;; tail: (lambda () (values '(1 2)))
+ ;; drop: (lambda () (values '(1 2)) 3)
+ ;; push: (lambda () (list (values '(10 12)) 1))
+ ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
+ (case context
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
+ ((push)
+ (case (length args)
+ ((0)
+ ;; FIXME: This is surely an error. We need to add a
+ ;; values-mismatch warning pass.
+ (comp-push (make-call src (make-primitive-ref #f 'values)
+ '())))
+ (else
+ ;; Taking advantage of unspecified order of evaluation of
+ ;; arguments.
+ (for-each comp-drop (cdr args))
+ (comp-push (car args))
+ (maybe-emit-return))))
+ ((vals)
+ (for-each comp-push args)
+ (emit-code #f (make-glil-const (length args)))
+ (emit-branch src 'br MVRA))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (let ((len (length args)))
+ (if (= len 1)
+ (make-glil-call 'return 1)
+ (make-glil-call 'return/values len)))))))
+
+ ((@call-with-values ,producer ,consumer)
+ ;; CONSUMER
+ ;; PRODUCER
+ ;; (mv-call MV)
+ ;; ([tail]-call 1)
+ ;; goto POST
+ ;; MV: [tail-]call/nargs
+ ;; POST: (maybe-drop)
+ (case context
+ ((vals)
+ ;; Fall back.
+ (comp-tail (make-primcall src 'call-with-values args)))
+ (else
+ (let ((MV (make-label)) (POST (make-label)))
+ (if (not (eq? context 'tail))
+ (emit-code src (make-glil-call 'new-frame 0)))
+ (comp-push consumer)
+ (emit-code src (make-glil-call 'new-frame 0))
+ (comp-push producer)
+ (emit-code src (make-glil-mv-call 0 MV))
+ (case context
+ ((tail) (emit-code src (make-glil-call 'tail-call 1)))
+ (else (emit-code src (make-glil-call 'call 1))
+ (emit-branch #f 'br POST)))
+ (emit-label MV)
+ (case context
+ ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
+ (else (emit-code src (make-glil-call 'call/nargs 0))
+ (emit-label POST)
+ (if (eq? context 'drop)
+ (emit-code #f (make-glil-call 'drop 1)))
+ (maybe-emit-return)))))))
+
+ ((@call-with-current-continuation ,proc)
+ (case context
+ ((tail)
+ (comp-push proc)
+ (emit-code src (make-glil-call 'tail-call/cc 1)))
+ ((vals)
+ (comp-vals
+ (make-primcall src 'call-with-current-continuation args)
+ MVRA)
+ (maybe-emit-return))
+ ((push)
+ (comp-push proc)
+ (emit-code src (make-glil-call 'call/cc 1))
+ (maybe-emit-return))
+ ((drop)
+ ;; Fall back.
+ (comp-tail
+ (make-primcall src 'call-with-current-continuation args)))))
+
+ ;; A hack for variable-set, the opcode for which takes its args
+ ;; reversed, relative to the variable-set! function
+ ((variable-set! ,var ,val)
+ (comp-push val)
+ (comp-push var)
+ (emit-code src (make-glil-call 'variable-set 2))
+ (case context
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ (else
+ (cond
+ ((or (hash-ref *primcall-ops* (cons name (length args)))
+ (hash-ref *primcall-ops* name))
+ => (lambda (op)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call op (length args)))
+ (case (instruction-pushes op)
+ ((0)
+ (case context
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+ ((1)
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
+ ((-1)
+ ;; A control instruction, like return/values. Here we
+ ;; just have to hope that the author of the tree-il
+ ;; knew what they were doing.
+ *unspecified*)
+ (else
+ (error "bad primitive op: too many pushes"
+ op (instruction-pushes op))))))
+ (else
+ ;; Fall back to the normal compilation strategy.
+ (comp-tail (make-call src (make-primitive-ref #f name) args)))))))
+
((<conditional> src test consequent alternate)
;; TEST
;; (br-if-not L1)
;; L1: alternate
;; L2:
(let ((L1 (make-label)) (L2 (make-label)))
- ;; need a pattern matcher
(record-case test
- ((<application> proc args)
- (record-case proc
- ((<primitive-ref> name)
- (let ((len (length args)))
- (cond
-
- ((and (eq? name 'eq?) (= len 2))
- (comp-push (car args))
- (comp-push (cadr args))
- (emit-branch src 'br-if-not-eq L1))
-
- ((and (eq? name 'null?) (= len 1))
- (comp-push (car args))
- (emit-branch src 'br-if-not-null L1))
-
- ((and (eq? name 'nil?) (= len 1))
- (comp-push (car args))
- (emit-branch src 'br-if-not-nil L1))
-
- ((and (eq? name 'not) (= len 1))
- (let ((app (car args)))
- (record-case app
- ((<application> proc args)
- (let ((len (length args)))
- (record-case proc
- ((<primitive-ref> name)
- (cond
-
- ((and (eq? name 'eq?) (= len 2))
- (comp-push (car args))
- (comp-push (cadr args))
- (emit-branch src 'br-if-eq L1))
-
- ((and (eq? name 'null?) (= len 1))
- (comp-push (car args))
- (emit-branch src 'br-if-null L1))
-
- ((and (eq? name 'nil?) (= len 1))
- (comp-push (car args))
- (emit-branch src 'br-if-nil L1))
-
- (else
- (comp-push app)
- (emit-branch src 'br-if L1))))
- (else
- (comp-push app)
- (emit-branch src 'br-if L1)))))
- (else
- (comp-push app)
- (emit-branch src 'br-if L1)))))
-
- (else
- (comp-push test)
- (emit-branch src 'br-if-not L1)))))
+ ((<primcall> name args)
+ (pmatch (cons name args)
+ ((eq? ,a ,b)
+ (comp-push a)
+ (comp-push b)
+ (emit-branch src 'br-if-not-eq L1))
+ ((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)
+ (pmatch (cons name args)
+ ((eq? ,a ,b)
+ (comp-push a)
+ (comp-push b)
+ (emit-branch src 'br-if-eq L1))
+ ((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))))
+ (else
+ (comp-push x)
+ (emit-branch src 'br-if L1))))
(else
(comp-push test)
(emit-branch src 'br-if-not L1))))
;; to have body's return value(s) on the stack while the unwinder runs,
;; then proceed with returning or dropping or what-have-you, interacting
;; with RA and MVRA. What have you, I say.
- ((<dynwind> src body winder unwinder)
+ ((<dynwind> src winder pre body post unwinder)
+ (define (thunk? x)
+ (and (lambda? x)
+ (null? (lambda-case-gensyms (lambda-body x)))))
+ (define (make-wrong-type-arg x)
+ (make-primcall src 'scm-error
+ (list
+ (make-const #f 'wrong-type-arg)
+ (make-const #f "dynamic-wind")
+ (make-const #f "Wrong type (expecting thunk): ~S")
+ (make-primcall #f 'list (list x))
+ (make-primcall #f 'list (list x)))))
+ (define (emit-thunk-check x)
+ (comp-drop (make-conditional
+ src
+ (make-primcall src 'thunk? (list x))
+ (make-void #f)
+ (make-wrong-type-arg x))))
+
+ ;; We know at this point that `winder' and `unwinder' are
+ ;; constant expressions and can be duplicated.
+ (if (not (thunk? winder))
+ (emit-thunk-check winder))
(comp-push winder)
+ (if (not (thunk? unwinder))
+ (emit-thunk-check unwinder))
(comp-push unwinder)
- (comp-drop (make-application src winder '()))
+ (comp-drop pre)
(emit-code #f (make-glil-call 'wind 2))
(case context
(comp-vals body MV)
;; one value: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; ...and return the val
(emit-code #f (make-glil-call 'return 1))
(emit-label MV)
;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; and return the values.
(emit-code #f (make-glil-call 'return/nvalues 1))))
(comp-push body)
;; and unwind, leaving the val on the stack
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '())))
+ (comp-drop post))
((vals)
(let ((MV (make-label)))
(emit-label MV)
;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; and goto the MVRA.
(emit-branch #f 'br MVRA)))
;; compile body, discarding values. then unwind...
(comp-drop body)
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; and fall through, or goto RA if there is one.
(if RA
(emit-branch #f 'br RA)))))
;;; open-coding primitive procedures
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012 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
expand-primitives!
effect-free-primitive? effect+exception-free-primitive?
constructor-primitive? accessor-primitive?
- singly-valued-primitive?))
+ singly-valued-primitive? equality-primitive?))
(define *interesting-primitive-names*
'(apply @apply
ash logand logior logxor
not
pair? null? list? symbol? vector? string? struct?
+ nil?
acons cons cons*
list vector
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- vector-ref vector-set!
+ vector-length vector-ref vector-set!
variable-ref variable-set!
variable-bound?
+ * - / 1- 1+ quotient remainder modulo
not
pair? null? list? symbol? vector? struct? string?
- string-length
+ nil?
+ string-length vector-length
;; These all should get expanded out by expand-primitives!.
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
ash logand logior logxor
not
pair? null? list? symbol? vector? acons cons cons*
+ nil?
list vector
car cdr
set-car! set-cdr!
bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
+(define *equality-primitives*
+ '(eq? eqv? equal?))
+
(define *effect-free-primitive-table* (make-hash-table))
(define *effect+exceptions-free-primitive-table* (make-hash-table))
(define *singly-valued-primitive-table* (make-hash-table))
+(define *equality-primitive-table* (make-hash-table))
(for-each (lambda (x)
(hashq-set! *effect-free-primitive-table* x #t))
(for-each (lambda (x)
(hashq-set! *singly-valued-primitive-table* x #t))
*singly-valued-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *equality-primitive-table* x #t))
+ *equality-primitives*)
(define (constructor-primitive? prim)
(memq prim *primitive-constructors*))
(hashq-ref *effect+exceptions-free-primitive-table* prim))
(define (singly-valued-primitive? prim)
(hashq-ref *singly-valued-primitive-table* prim))
+(define (equality-primitive? prim)
+ (hashq-ref *equality-primitive-table* prim))
(define (resolve-primitives! x mod)
+ (define local-definitions
+ (make-hash-table))
+
+ (let collect-local-definitions ((x x))
+ (record-case x
+ ((<toplevel-define> name)
+ (hashq-set! local-definitions name #t))
+ ((<seq> head tail)
+ (collect-local-definitions head)
+ (collect-local-definitions tail))
+ (else #f)))
+
(post-order!
(lambda (x)
(record-case x
((<toplevel-ref> src name)
- (and=> (hashq-ref *interesting-primitive-vars*
- (module-variable mod name))
+ (and=> (and (not (hashq-ref local-definitions name))
+ (hashq-ref *interesting-primitive-vars*
+ (module-variable mod name)))
(lambda (name) (make-primitive-ref src name))))
((<module-ref> src mod name public?)
;; for the moment, we're disabling primitive resolution for
(and=> (hashq-ref *interesting-primitive-vars*
(module-variable m name))
(lambda (name) (make-primitive-ref src name))))))
+ ((<call> src proc args)
+ (and (primitive-ref? proc)
+ (make-primcall src (primitive-ref-name proc) args)))
(else #f)))
x))
(pre-order!
(lambda (x)
(record-case x
- ((<application> src proc args)
- (and (primitive-ref? proc)
- (let ((expand (hashq-ref *primitive-expand-table*
- (primitive-ref-name proc))))
- (and expand (apply expand src args)))))
+ ((<primcall> src name args)
+ (let ((expand (hashq-ref *primitive-expand-table* name)))
+ (and expand (apply expand src args))))
(else #f)))
x))
(lp (cdr in)
(cons (if (eq? (caar in) 'quote)
`(make-const src ,@(cdar in))
- `(make-application src (make-primitive-ref src ',(caar in))
- ,(inline-args (cdar in))))
+ `(make-primcall src ',(caar in)
+ ,(inline-args (cdar in))))
out)))
((symbol? (car in))
;; assume it's locally bound
,(consequent then)
,(consequent else)))
(else
- `(make-application src (make-primitive-ref src ',(car exp))
- ,(inline-args (cdr exp))))))
+ `(make-primcall src ',(car exp)
+ ,(inline-args (cdr exp))))))
((symbol? exp)
;; assume locally bound
exp)
(define-primitive-expander f64vector-set! (vec i x)
(bytevector-ieee-double-native-set! vec (* i 8) x))
-(hashq-set! *primitive-expand-table*
- 'dynamic-wind
- (case-lambda
- ((src pre thunk post)
- (let ((PRE (gensym " pre"))
- (THUNK (gensym " thunk"))
- (POST (gensym " post")))
- (make-let
- src
- '(pre thunk post)
- (list PRE THUNK POST)
- (list pre thunk post)
- (make-dynwind
- src
- (make-lexical-ref #f 'pre PRE)
- (make-application #f (make-lexical-ref #f 'thunk THUNK) '())
- (make-lexical-ref #f 'post POST)))))
- (else #f)))
-
(hashq-set! *primitive-expand-table*
'@dynamic-wind
(case-lambda
((src pre expr post)
- (let ((PRE (gensym " pre"))
- (POST (gensym " post")))
+ (let ((PRE (gensym "pre-"))
+ (POST (gensym "post-")))
(make-let
src
'(pre post)
(make-dynwind
src
(make-lexical-ref #f 'pre PRE)
+ (make-call #f (make-lexical-ref #f 'pre PRE) '())
expr
+ (make-call #f (make-lexical-ref #f 'post POST) '())
(make-lexical-ref #f 'post POST)))))))
(hashq-set! *primitive-expand-table*
;; trickery here.
(make-lambda-case
(tree-il-src handler) '() #f 'args #f '() (list args-sym)
- (make-application #f (make-primitive-ref #f 'apply)
- (list handler
- (make-lexical-ref #f 'args args-sym)))
+ (make-primcall #f 'apply
+ (list handler
+ (make-lexical-ref #f 'args args-sym)))
#f))))
(else #f)))
'call-with-prompt
(case-lambda
((src tag thunk handler)
- ;; Sigh. Until the inliner does its job, manually inline
- ;; (let ((h (lambda ...))) (prompt k x h))
- (cond
- ((lambda? handler)
- (let ((args-sym (gensym)))
- (make-prompt
- src tag (make-application #f thunk '())
- ;; If handler itself is a lambda, the inliner can do some
- ;; trickery here.
- (make-lambda-case
- (tree-il-src handler) '() #f 'args #f '() (list args-sym)
- (make-application #f (make-primitive-ref #f 'apply)
- (list handler
- (make-lexical-ref #f 'args args-sym)))
- #f))))
- (else #f)))
+ (let ((handler-sym (gensym))
+ (args-sym (gensym)))
+ (make-let
+ src '(handler) (list handler-sym) (list handler)
+ (make-prompt
+ src tag (make-call #f thunk '())
+ ;; If handler itself is a lambda, the inliner can do some
+ ;; trickery here.
+ (make-lambda-case
+ (tree-il-src handler) '() #f 'args #f '() (list args-sym)
+ (make-primcall
+ #f 'apply
+ (list (make-lexical-ref #f 'handler handler-sym)
+ (make-lexical-ref #f 'args args-sym)))
+ #f)))))
(else #f)))
(hashq-set! *primitive-expand-table*
HCoop / bpt / guile.git / commitdiff