diff options
author | BT Templeton <bpt@hcoop.net> | 2012-03-05 16:52:05 -0500 |
---|---|---|
committer | BT Templeton <bpt@hcoop.net> | 2012-03-05 16:52:05 -0500 |
commit | 5ddd9645c94f339f8795bf9b3ece8d518a8de004 (patch) | |
tree | b7759e320ef4f146e01d4f1b8a0bdddf07cb7799 | |
parent | d019ef92886bebc2d0e79db7c16abacc50b6f77d (diff) | |
parent | eaeda0d550c513f4d134304d9adda28e1d65a23b (diff) | |
download | guile-5ddd9645c94f339f8795bf9b3ece8d518a8de004.tar.gz |
Merge branch 'bt/elisp'
Conflicts:
am/guilec
libguile/_scm.h
libguile/vm-i-scheme.c
module/language/elisp/compile-tree-il.scm
module/language/elisp/runtime.scm
module/language/elisp/runtime/macros.scm
module/language/tree-il/compile-glil.scm
module/language/tree-il/primitives.scm
23 files changed, 1316 insertions, 1632 deletions
@@ -1,14 +1,14 @@ # -*- makefile -*- -GOBJECTS = $(SOURCES:%.scm=%.go) +GOBJECTS = $(SOURCES:%.scm=%.go) $(ELISP_SOURCES:%.el=%.go) GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat moddir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/$(modpath) -nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) +nobase_mod_DATA = $(SOURCES) $(ELISP_SOURCES) $(NOCOMP_SOURCES) ccachedir = $(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache/$(modpath) nobase_ccache_DATA = $(GOBJECTS) -EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES) -ETAGS_ARGS = $(SOURCES) $(NOCOMP_SOURCES) +EXTRA_DIST = $(SOURCES) $(ELISP_SOURCES) $(NOCOMP_SOURCES) +ETAGS_ARGS = $(SOURCES) $(ELISP_SOURCES) $(NOCOMP_SOURCES) CLEANFILES = $(GOBJECTS) @@ -24,7 +24,8 @@ AM_V_GUILEC = $(AM_V_GUILEC_$(V)) AM_V_GUILEC_ = $(AM_V_GUILEC_$(AM_DEFAULT_VERBOSITY)) AM_V_GUILEC_0 = @echo " GUILEC" $@; -SUFFIXES = .scm .go +SUFFIXES = .scm .el .go + .scm.go: $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \ $(top_builddir)/meta/uninstalled-env \ @@ -32,3 +33,11 @@ SUFFIXES = .scm .go -L "$(abs_srcdir)" -L "$(abs_builddir)" \ -L "$(abs_top_srcdir)/guile-readline" \ -o "$@" "$<" + +.el.go: + $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \ + $(top_builddir)/meta/uninstalled-env \ + guild compile --target="$(host)" $(GUILE_WARNINGS) \ + -L "$(abs_srcdir)" -L "$(abs_builddir)" \ + -L "$(abs_top_srcdir)/guile-readline" \ + --from=elisp -o "$@" "$<" diff --git a/libguile/_scm.h b/libguile/_scm.h index a7a3ad254..c3384be68 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -262,7 +262,7 @@ void scm_ia64_longjmp (scm_i_jmp_buf *, int); /* Major and minor versions must be single characters. */ #define SCM_OBJCODE_MAJOR_VERSION 3 -#define SCM_OBJCODE_MINOR_VERSION 0 +#define SCM_OBJCODE_MINOR_VERSION 1 #define SCM_OBJCODE_MAJOR_VERSION_STRING \ SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION) #define SCM_OBJCODE_MINOR_VERSION_STRING \ diff --git a/libguile/boolean.c b/libguile/boolean.c index 3bf672d6d..f8c773839 100644 --- a/libguile/boolean.c +++ b/libguile/boolean.c @@ -62,6 +62,14 @@ SCM_DEFINE (scm_not, "not", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_nil_p, "nil?", 1, 0, 0, + (SCM x), + "Return @code{#t} iff @var{x} is nil, else return @code{#f}.") +#define FUNC_NAME s_scm_nil_p +{ + return scm_from_bool (scm_is_lisp_false (x)); +} +#undef FUNC_NAME SCM_DEFINE (scm_boolean_p, "boolean?", 1, 0, 0, (SCM obj), diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index ad16c46cc..89c3555ce 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -65,7 +65,19 @@ VM_DEFINE_FUNCTION (133, not_nullp, "not-null?", 1) RETURN (scm_from_bool (!scm_is_null (x))); } -VM_DEFINE_FUNCTION (134, eqv, "eqv?", 2) +VM_DEFINE_FUNCTION (134, nilp, "nil?", 1) +{ + ARGS1 (x); + RETURN (scm_from_bool (scm_is_lisp_false (x))); +} + +VM_DEFINE_FUNCTION (135, not_nilp, "not-nil?", 1) +{ + ARGS1 (x); + RETURN (scm_from_bool (!scm_is_lisp_false (x))); +} + +VM_DEFINE_FUNCTION (136, eqv, "eqv?", 2) { ARGS2 (x, y); if (scm_is_eq (x, y)) @@ -76,7 +88,7 @@ VM_DEFINE_FUNCTION (134, eqv, "eqv?", 2) RETURN (scm_eqv_p (x, y)); } -VM_DEFINE_FUNCTION (135, equal, "equal?", 2) +VM_DEFINE_FUNCTION (137, equal, "equal?", 2) { ARGS2 (x, y); if (scm_is_eq (x, y)) @@ -87,25 +99,25 @@ VM_DEFINE_FUNCTION (135, equal, "equal?", 2) RETURN (scm_equal_p (x, y)); } -VM_DEFINE_FUNCTION (136, pairp, "pair?", 1) +VM_DEFINE_FUNCTION (138, pairp, "pair?", 1) { ARGS1 (x); RETURN (scm_from_bool (scm_is_pair (x))); } -VM_DEFINE_FUNCTION (137, listp, "list?", 1) +VM_DEFINE_FUNCTION (139, listp, "list?", 1) { ARGS1 (x); RETURN (scm_from_bool (scm_ilength (x) >= 0)); } -VM_DEFINE_FUNCTION (138, symbolp, "symbol?", 1) +VM_DEFINE_FUNCTION (140, symbolp, "symbol?", 1) { ARGS1 (x); RETURN (scm_from_bool (scm_is_symbol (x))); } -VM_DEFINE_FUNCTION (139, vectorp, "vector?", 1) +VM_DEFINE_FUNCTION (141, vectorp, "vector?", 1) { ARGS1 (x); RETURN (scm_from_bool (SCM_I_IS_VECTOR (x))); @@ -116,7 +128,7 @@ VM_DEFINE_FUNCTION (139, vectorp, "vector?", 1) * Basic data */ -VM_DEFINE_FUNCTION (140, cons, "cons", 2) +VM_DEFINE_FUNCTION (142, cons, "cons", 2) { ARGS2 (x, y); CONS (x, x, y); @@ -130,21 +142,21 @@ VM_DEFINE_FUNCTION (140, cons, "cons", 2) goto vm_error_not_a_pair; \ } -VM_DEFINE_FUNCTION (141, car, "car", 1) +VM_DEFINE_FUNCTION (143, car, "car", 1) { ARGS1 (x); VM_VALIDATE_CONS (x, "car"); RETURN (SCM_CAR (x)); } -VM_DEFINE_FUNCTION (142, cdr, "cdr", 1) +VM_DEFINE_FUNCTION (144, cdr, "cdr", 1) { ARGS1 (x); VM_VALIDATE_CONS (x, "cdr"); RETURN (SCM_CDR (x)); } -VM_DEFINE_INSTRUCTION (143, set_car, "set-car!", 0, 2, 0) +VM_DEFINE_INSTRUCTION (145, set_car, "set-car!", 0, 2, 0) { SCM x, y; POP2 (y, x); @@ -153,7 +165,7 @@ VM_DEFINE_INSTRUCTION (143, set_car, "set-car!", 0, 2, 0) NEXT; } -VM_DEFINE_INSTRUCTION (144, set_cdr, "set-cdr!", 0, 2, 0) +VM_DEFINE_INSTRUCTION (146, set_cdr, "set-cdr!", 0, 2, 0) { SCM x, y; POP2 (y, x); @@ -178,27 +190,27 @@ VM_DEFINE_INSTRUCTION (144, set_cdr, "set-cdr!", 0, 2, 0) RETURN (srel (x, y)); \ } -VM_DEFINE_FUNCTION (145, ee, "ee?", 2) +VM_DEFINE_FUNCTION (147, ee, "ee?", 2) { REL (==, scm_num_eq_p); } -VM_DEFINE_FUNCTION (146, lt, "lt?", 2) +VM_DEFINE_FUNCTION (148, lt, "lt?", 2) { REL (<, scm_less_p); } -VM_DEFINE_FUNCTION (147, le, "le?", 2) +VM_DEFINE_FUNCTION (149, le, "le?", 2) { REL (<=, scm_leq_p); } -VM_DEFINE_FUNCTION (148, gt, "gt?", 2) +VM_DEFINE_FUNCTION (150, gt, "gt?", 2) { REL (>, scm_gr_p); } -VM_DEFINE_FUNCTION (149, ge, "ge?", 2) +VM_DEFINE_FUNCTION (151, ge, "ge?", 2) { REL (>=, scm_geq_p); } @@ -280,7 +292,7 @@ VM_DEFINE_FUNCTION (149, ge, "ge?", 2) #endif -VM_DEFINE_FUNCTION (150, add, "add", 2) +VM_DEFINE_FUNCTION (152, add, "add", 2) { #ifndef ASM_ADD FUNC2 (+, scm_sum); @@ -292,7 +304,7 @@ VM_DEFINE_FUNCTION (150, add, "add", 2) #endif } -VM_DEFINE_FUNCTION (151, add1, "add1", 1) +VM_DEFINE_FUNCTION (153, add1, "add1", 1) { ARGS1 (x); @@ -314,7 +326,7 @@ VM_DEFINE_FUNCTION (151, add1, "add1", 1) RETURN (scm_sum (x, SCM_I_MAKINUM (1))); } -VM_DEFINE_FUNCTION (152, sub, "sub", 2) +VM_DEFINE_FUNCTION (154, sub, "sub", 2) { #ifndef ASM_SUB FUNC2 (-, scm_difference); @@ -326,7 +338,7 @@ VM_DEFINE_FUNCTION (152, sub, "sub", 2) #endif } -VM_DEFINE_FUNCTION (153, sub1, "sub1", 1) +VM_DEFINE_FUNCTION (155, sub1, "sub1", 1) { ARGS1 (x); @@ -351,42 +363,42 @@ VM_DEFINE_FUNCTION (153, sub1, "sub1", 1) # undef ASM_ADD # undef ASM_SUB -VM_DEFINE_FUNCTION (154, mul, "mul", 2) +VM_DEFINE_FUNCTION (156, mul, "mul", 2) { ARGS2 (x, y); SYNC_REGISTER (); RETURN (scm_product (x, y)); } -VM_DEFINE_FUNCTION (155, div, "div", 2) +VM_DEFINE_FUNCTION (157, div, "div", 2) { ARGS2 (x, y); SYNC_REGISTER (); RETURN (scm_divide (x, y)); } -VM_DEFINE_FUNCTION (156, quo, "quo", 2) +VM_DEFINE_FUNCTION (158, quo, "quo", 2) { ARGS2 (x, y); SYNC_REGISTER (); RETURN (scm_quotient (x, y)); } -VM_DEFINE_FUNCTION (157, rem, "rem", 2) +VM_DEFINE_FUNCTION (159, rem, "rem", 2) { ARGS2 (x, y); SYNC_REGISTER (); RETURN (scm_remainder (x, y)); } -VM_DEFINE_FUNCTION (158, mod, "mod", 2) +VM_DEFINE_FUNCTION (160, mod, "mod", 2) { ARGS2 (x, y); SYNC_REGISTER (); RETURN (scm_modulo (x, y)); } -VM_DEFINE_FUNCTION (159, ash, "ash", 2) +VM_DEFINE_FUNCTION (161, ash, "ash", 2) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -415,7 +427,7 @@ VM_DEFINE_FUNCTION (159, ash, "ash", 2) RETURN (scm_ash (x, y)); } -VM_DEFINE_FUNCTION (160, logand, "logand", 2) +VM_DEFINE_FUNCTION (162, logand, "logand", 2) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -424,7 +436,7 @@ VM_DEFINE_FUNCTION (160, logand, "logand", 2) RETURN (scm_logand (x, y)); } -VM_DEFINE_FUNCTION (161, logior, "logior", 2) +VM_DEFINE_FUNCTION (163, logior, "logior", 2) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -433,7 +445,7 @@ VM_DEFINE_FUNCTION (161, logior, "logior", 2) RETURN (scm_logior (x, y)); } -VM_DEFINE_FUNCTION (162, logxor, "logxor", 2) +VM_DEFINE_FUNCTION (164, logxor, "logxor", 2) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -447,7 +459,7 @@ VM_DEFINE_FUNCTION (162, logxor, "logxor", 2) * Strings */ -VM_DEFINE_FUNCTION (163, string_length, "string-length", 1) +VM_DEFINE_FUNCTION (165, string_length, "string-length", 1) { ARGS1 (str); if (SCM_LIKELY (scm_is_string (str))) @@ -459,7 +471,7 @@ VM_DEFINE_FUNCTION (163, string_length, "string-length", 1) } } -VM_DEFINE_FUNCTION (164, string_ref, "string-ref", 2) +VM_DEFINE_FUNCTION (166, string_ref, "string-ref", 2) { scm_t_signed_bits i = 0; ARGS2 (str, idx); @@ -482,7 +494,7 @@ VM_DEFINE_FUNCTION (164, string_ref, "string-ref", 2) * Vectors and arrays */ -VM_DEFINE_FUNCTION (165, vector_length, "vector-length", 1) +VM_DEFINE_FUNCTION (167, vector_length, "vector-length", 1) { ARGS1 (vect); if (SCM_LIKELY (SCM_I_IS_VECTOR (vect))) @@ -494,7 +506,7 @@ VM_DEFINE_FUNCTION (165, vector_length, "vector-length", 1) } } -VM_DEFINE_FUNCTION (166, vector_ref, "vector-ref", 2) +VM_DEFINE_FUNCTION (168, vector_ref, "vector-ref", 2) { scm_t_signed_bits i = 0; ARGS2 (vect, idx); @@ -510,7 +522,7 @@ VM_DEFINE_FUNCTION (166, vector_ref, "vector-ref", 2) } } -VM_DEFINE_INSTRUCTION (167, vector_set, "vector-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (169, vector_set, "vector-set", 0, 3, 0) { scm_t_signed_bits i = 0; SCM vect, idx, val; @@ -528,7 +540,7 @@ VM_DEFINE_INSTRUCTION (167, vector_set, "vector-set", 0, 3, 0) NEXT; } -VM_DEFINE_INSTRUCTION (168, make_array, "make-array", 3, -1, 1) +VM_DEFINE_INSTRUCTION (170, make_array, "make-array", 3, -1, 1) { scm_t_uint32 len; SCM shape, ret; @@ -557,20 +569,20 @@ VM_DEFINE_INSTRUCTION (168, make_array, "make-array", 3, -1, 1) goto vm_error_not_a_struct; \ } -VM_DEFINE_FUNCTION (169, struct_p, "struct?", 1) +VM_DEFINE_FUNCTION (171, struct_p, "struct?", 1) { ARGS1 (obj); RETURN (scm_from_bool (SCM_STRUCTP (obj))); } -VM_DEFINE_FUNCTION (170, struct_vtable, "struct-vtable", 1) +VM_DEFINE_FUNCTION (172, struct_vtable, "struct-vtable", 1) { ARGS1 (obj); VM_VALIDATE_STRUCT (obj, "struct_vtable"); RETURN (SCM_STRUCT_VTABLE (obj)); } -VM_DEFINE_INSTRUCTION (171, make_struct, "make-struct", 2, -1, 1) +VM_DEFINE_INSTRUCTION (173, make_struct, "make-struct", 2, -1, 1) { unsigned h = FETCH (); unsigned l = FETCH (); @@ -603,7 +615,7 @@ VM_DEFINE_INSTRUCTION (171, make_struct, "make-struct", 2, -1, 1) NEXT; } -VM_DEFINE_FUNCTION (172, struct_ref, "struct-ref", 2) +VM_DEFINE_FUNCTION (174, struct_ref, "struct-ref", 2) { ARGS2 (obj, pos); @@ -633,7 +645,7 @@ VM_DEFINE_FUNCTION (172, struct_ref, "struct-ref", 2) RETURN (scm_struct_ref (obj, pos)); } -VM_DEFINE_FUNCTION (173, struct_set, "struct-set", 3) +VM_DEFINE_FUNCTION (175, struct_set, "struct-set", 3) { ARGS3 (obj, pos, val); @@ -667,7 +679,7 @@ VM_DEFINE_FUNCTION (173, struct_set, "struct-set", 3) /* * GOOPS support */ -VM_DEFINE_FUNCTION (174, class_of, "class-of", 1) +VM_DEFINE_FUNCTION (176, class_of, "class-of", 1) { ARGS1 (obj); if (SCM_INSTANCEP (obj)) @@ -677,7 +689,7 @@ VM_DEFINE_FUNCTION (174, class_of, "class-of", 1) } /* FIXME: No checking whatsoever. */ -VM_DEFINE_FUNCTION (175, slot_ref, "slot-ref", 2) +VM_DEFINE_FUNCTION (177, slot_ref, "slot-ref", 2) { size_t slot; ARGS2 (instance, idx); @@ -686,7 +698,7 @@ VM_DEFINE_FUNCTION (175, slot_ref, "slot-ref", 2) } /* FIXME: No checking whatsoever. */ -VM_DEFINE_INSTRUCTION (176, slot_set, "slot-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (178, slot_set, "slot-set", 0, 3, 0) { SCM instance, idx, val; size_t slot; @@ -729,21 +741,21 @@ VM_DEFINE_INSTRUCTION (176, slot_set, "slot-set", 0, 3, 0) #define ALIGNED_P(ptr, type) \ ((scm_t_uintptr) (ptr) % alignof_type (type) == 0) -VM_DEFINE_FUNCTION (177, bv_u16_ref, "bv-u16-ref", 3) +VM_DEFINE_FUNCTION (179, bv_u16_ref, "bv-u16-ref", 3) BV_REF_WITH_ENDIANNESS (u16, u16) -VM_DEFINE_FUNCTION (178, bv_s16_ref, "bv-s16-ref", 3) +VM_DEFINE_FUNCTION (180, bv_s16_ref, "bv-s16-ref", 3) BV_REF_WITH_ENDIANNESS (s16, s16) -VM_DEFINE_FUNCTION (179, bv_u32_ref, "bv-u32-ref", 3) +VM_DEFINE_FUNCTION (181, bv_u32_ref, "bv-u32-ref", 3) BV_REF_WITH_ENDIANNESS (u32, u32) -VM_DEFINE_FUNCTION (180, bv_s32_ref, "bv-s32-ref", 3) +VM_DEFINE_FUNCTION (182, bv_s32_ref, "bv-s32-ref", 3) BV_REF_WITH_ENDIANNESS (s32, s32) -VM_DEFINE_FUNCTION (181, bv_u64_ref, "bv-u64-ref", 3) +VM_DEFINE_FUNCTION (183, bv_u64_ref, "bv-u64-ref", 3) BV_REF_WITH_ENDIANNESS (u64, u64) -VM_DEFINE_FUNCTION (182, bv_s64_ref, "bv-s64-ref", 3) +VM_DEFINE_FUNCTION (184, bv_s64_ref, "bv-s64-ref", 3) BV_REF_WITH_ENDIANNESS (s64, s64) -VM_DEFINE_FUNCTION (183, bv_f32_ref, "bv-f32-ref", 3) +VM_DEFINE_FUNCTION (185, bv_f32_ref, "bv-f32-ref", 3) BV_REF_WITH_ENDIANNESS (f32, ieee_single) -VM_DEFINE_FUNCTION (184, bv_f64_ref, "bv-f64-ref", 3) +VM_DEFINE_FUNCTION (186, bv_f64_ref, "bv-f64-ref", 3) BV_REF_WITH_ENDIANNESS (f64, ieee_double) #undef BV_REF_WITH_ENDIANNESS @@ -821,33 +833,33 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \ } -VM_DEFINE_FUNCTION (185, bv_u8_ref, "bv-u8-ref", 2) +VM_DEFINE_FUNCTION (187, bv_u8_ref, "bv-u8-ref", 2) BV_FIXABLE_INT_REF (u8, u8, uint8, 1) -VM_DEFINE_FUNCTION (186, bv_s8_ref, "bv-s8-ref", 2) +VM_DEFINE_FUNCTION (188, bv_s8_ref, "bv-s8-ref", 2) BV_FIXABLE_INT_REF (s8, s8, int8, 1) -VM_DEFINE_FUNCTION (187, bv_u16_native_ref, "bv-u16-native-ref", 2) +VM_DEFINE_FUNCTION (189, bv_u16_native_ref, "bv-u16-native-ref", 2) BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2) -VM_DEFINE_FUNCTION (188, bv_s16_native_ref, "bv-s16-native-ref", 2) +VM_DEFINE_FUNCTION (190, bv_s16_native_ref, "bv-s16-native-ref", 2) BV_FIXABLE_INT_REF (s16, s16_native, int16, 2) -VM_DEFINE_FUNCTION (189, bv_u32_native_ref, "bv-u32-native-ref", 2) +VM_DEFINE_FUNCTION (191, bv_u32_native_ref, "bv-u32-native-ref", 2) #if SIZEOF_VOID_P > 4 BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4) #else BV_INT_REF (u32, uint32, 4) #endif -VM_DEFINE_FUNCTION (190, bv_s32_native_ref, "bv-s32-native-ref", 2) +VM_DEFINE_FUNCTION (192, bv_s32_native_ref, "bv-s32-native-ref", 2) #if SIZEOF_VOID_P > 4 BV_FIXABLE_INT_REF (s32, s32_native, int32, 4) #else BV_INT_REF (s32, int32, 4) #endif -VM_DEFINE_FUNCTION (191, bv_u64_native_ref, "bv-u64-native-ref", 2) +VM_DEFINE_FUNCTION (193, bv_u64_native_ref, "bv-u64-native-ref", 2) BV_INT_REF (u64, uint64, 8) -VM_DEFINE_FUNCTION (192, bv_s64_native_ref, "bv-s64-native-ref", 2) +VM_DEFINE_FUNCTION (194, bv_s64_native_ref, "bv-s64-native-ref", 2) BV_INT_REF (s64, int64, 8) -VM_DEFINE_FUNCTION (193, bv_f32_native_ref, "bv-f32-native-ref", 2) +VM_DEFINE_FUNCTION (195, bv_f32_native_ref, "bv-f32-native-ref", 2) BV_FLOAT_REF (f32, ieee_single, float, 4) -VM_DEFINE_FUNCTION (194, bv_f64_native_ref, "bv-f64-native-ref", 2) +VM_DEFINE_FUNCTION (196, bv_f64_native_ref, "bv-f64-native-ref", 2) BV_FLOAT_REF (f64, ieee_double, double, 8) #undef BV_FIXABLE_INT_REF @@ -870,21 +882,21 @@ BV_FLOAT_REF (f64, ieee_double, double, 8) } \ } -VM_DEFINE_INSTRUCTION (195, bv_u16_set, "bv-u16-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (197, bv_u16_set, "bv-u16-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u16, u16) -VM_DEFINE_INSTRUCTION (196, bv_s16_set, "bv-s16-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (198, bv_s16_set, "bv-s16-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s16, s16) -VM_DEFINE_INSTRUCTION (197, bv_u32_set, "bv-u32-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (199, bv_u32_set, "bv-u32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u32, u32) -VM_DEFINE_INSTRUCTION (198, bv_s32_set, "bv-s32-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (200, bv_s32_set, "bv-s32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s32, s32) -VM_DEFINE_INSTRUCTION (199, bv_u64_set, "bv-u64-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (201, bv_u64_set, "bv-u64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u64, u64) -VM_DEFINE_INSTRUCTION (200, bv_s64_set, "bv-s64-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (202, bv_s64_set, "bv-s64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s64, s64) -VM_DEFINE_INSTRUCTION (201, bv_f32_set, "bv-f32-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (203, bv_f32_set, "bv-f32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (f32, ieee_single) -VM_DEFINE_INSTRUCTION (202, bv_f64_set, "bv-f64-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (204, bv_f64_set, "bv-f64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (f64, ieee_double) #undef BV_SET_WITH_ENDIANNESS @@ -964,33 +976,33 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) NEXT; \ } -VM_DEFINE_INSTRUCTION (203, bv_u8_set, "bv-u8-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (205, bv_u8_set, "bv-u8-set", 0, 3, 0) BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1) -VM_DEFINE_INSTRUCTION (204, bv_s8_set, "bv-s8-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (206, bv_s8_set, "bv-s8-set", 0, 3, 0) BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1) -VM_DEFINE_INSTRUCTION (205, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (207, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0) BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2) -VM_DEFINE_INSTRUCTION (206, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (208, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0) BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2) -VM_DEFINE_INSTRUCTION (207, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (209, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0) #if SIZEOF_VOID_P > 4 BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4) #else BV_INT_SET (u32, uint32, 4) #endif -VM_DEFINE_INSTRUCTION (208, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (210, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0) #if SIZEOF_VOID_P > 4 BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4) #else BV_INT_SET (s32, int32, 4) #endif -VM_DEFINE_INSTRUCTION (209, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (211, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0) BV_INT_SET (u64, uint64, 8) -VM_DEFINE_INSTRUCTION (210, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (212, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0) BV_INT_SET (s64, int64, 8) -VM_DEFINE_INSTRUCTION (211, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (213, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0) BV_FLOAT_SET (f32, ieee_single, float, 4) -VM_DEFINE_INSTRUCTION (212, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (214, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0) BV_FLOAT_SET (f64, ieee_double, double, 8) #undef BV_FIXABLE_INT_SET diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 2fce8346d..114b4224f 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -538,12 +538,25 @@ VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0) BR (!scm_is_null (x)); } +VM_DEFINE_INSTRUCTION (41, br_if_nil, "br-if-nil", 3, 0, 0) +{ + SCM x; + POP (x); + BR (scm_is_lisp_false (x)); +} + +VM_DEFINE_INSTRUCTION (42, br_if_not_nil, "br-if-not-nil", 3, 0, 0) +{ + SCM x; + POP (x); + BR (!scm_is_lisp_false (x)); +} /* * Subprogram call */ -VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0) +VM_DEFINE_INSTRUCTION (43, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0) { scm_t_ptrdiff n; scm_t_int32 offset; @@ -555,7 +568,7 @@ VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0) +VM_DEFINE_INSTRUCTION (44, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0) { scm_t_ptrdiff n; scm_t_int32 offset; @@ -567,7 +580,7 @@ VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0) +VM_DEFINE_INSTRUCTION (45, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0) { scm_t_ptrdiff n; scm_t_int32 offset; @@ -580,7 +593,7 @@ VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (44, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0) +VM_DEFINE_INSTRUCTION (46, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0) { scm_t_ptrdiff n; n = FETCH () << 8; @@ -590,7 +603,7 @@ VM_DEFINE_INSTRUCTION (44, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (45, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0) +VM_DEFINE_INSTRUCTION (47, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0) { scm_t_ptrdiff n; n = FETCH () << 8; @@ -600,7 +613,7 @@ VM_DEFINE_INSTRUCTION (45, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (46, bind_optionals, "bind-optionals", 2, -1, -1) +VM_DEFINE_INSTRUCTION (48, bind_optionals, "bind-optionals", 2, -1, -1) { scm_t_ptrdiff n; n = FETCH () << 8; @@ -610,7 +623,7 @@ VM_DEFINE_INSTRUCTION (46, bind_optionals, "bind-optionals", 2, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1) +VM_DEFINE_INSTRUCTION (49, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1) { SCM *walk; scm_t_ptrdiff nreq, nreq_and_opt, ntotal; @@ -653,7 +666,7 @@ VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6, #define F_ALLOW_OTHER_KEYS 1 #define F_REST 2 -VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0) +VM_DEFINE_INSTRUCTION (50, bind_kwargs, "bind-kwargs", 5, 0, 0) { scm_t_uint16 idx; scm_t_ptrdiff nkw; @@ -706,7 +719,7 @@ VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0) #undef F_REST -VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1) +VM_DEFINE_INSTRUCTION (51, push_rest, "push-rest", 2, -1, -1) { scm_t_ptrdiff n; SCM rest = SCM_EOL; @@ -719,7 +732,7 @@ VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (50, bind_rest, "bind-rest", 4, -1, -1) +VM_DEFINE_INSTRUCTION (52, bind_rest, "bind-rest", 4, -1, -1) { scm_t_ptrdiff n; scm_t_uint32 i; @@ -735,7 +748,7 @@ VM_DEFINE_INSTRUCTION (50, bind_rest, "bind-rest", 4, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (51, reserve_locals, "reserve-locals", 2, -1, -1) +VM_DEFINE_INSTRUCTION (53, reserve_locals, "reserve-locals", 2, -1, -1) { SCM *old_sp; scm_t_int32 n; @@ -756,7 +769,7 @@ VM_DEFINE_INSTRUCTION (51, reserve_locals, "reserve-locals", 2, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3) +VM_DEFINE_INSTRUCTION (54, new_frame, "new-frame", 0, 0, 3) { /* NB: if you change this, see frames.c:vm-frame-num-locals */ /* and frames.h, vm-engine.c, etc of course */ @@ -771,7 +784,7 @@ VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3) NEXT; } -VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1) +VM_DEFINE_INSTRUCTION (55, call, "call", 1, -1, 1) { nargs = FETCH (); @@ -819,7 +832,7 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1) +VM_DEFINE_INSTRUCTION (56, tail_call, "tail-call", 1, -1, 1) { nargs = FETCH (); @@ -870,7 +883,7 @@ VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1) } } -VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1) +VM_DEFINE_INSTRUCTION (57, subr_call, "subr-call", 1, -1, -1) { SCM pointer, ret; SCM (*subr)(); @@ -939,7 +952,7 @@ VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1) } } -VM_DEFINE_INSTRUCTION (56, smob_call, "smob-call", 1, -1, -1) +VM_DEFINE_INSTRUCTION (58, smob_call, "smob-call", 1, -1, -1) { SCM smob, ret; SCM (*subr)(); @@ -986,7 +999,7 @@ VM_DEFINE_INSTRUCTION (56, smob_call, "smob-call", 1, -1, -1) } } -VM_DEFINE_INSTRUCTION (57, foreign_call, "foreign-call", 1, -1, -1) +VM_DEFINE_INSTRUCTION (59, foreign_call, "foreign-call", 1, -1, -1) { SCM foreign, ret; nargs = FETCH (); @@ -1014,7 +1027,7 @@ VM_DEFINE_INSTRUCTION (57, foreign_call, "foreign-call", 1, -1, -1) } } -VM_DEFINE_INSTRUCTION (58, continuation_call, "continuation-call", 0, -1, 0) +VM_DEFINE_INSTRUCTION (60, continuation_call, "continuation-call", 0, -1, 0) { SCM contregs; POP (contregs); @@ -1030,7 +1043,7 @@ VM_DEFINE_INSTRUCTION (58, continuation_call, "continuation-call", 0, -1, 0) abort (); } -VM_DEFINE_INSTRUCTION (59, partial_cont_call, "partial-cont-call", 0, -1, 0) +VM_DEFINE_INSTRUCTION (61, partial_cont_call, "partial-cont-call", 0, -1, 0) { SCM vmcont; scm_t_ptrdiff reloc; @@ -1081,7 +1094,7 @@ VM_DEFINE_INSTRUCTION (59, partial_cont_call, "partial-cont-call", 0, -1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (60, tail_call_nargs, "tail-call/nargs", 0, 0, 1) +VM_DEFINE_INSTRUCTION (62, tail_call_nargs, "tail-call/nargs", 0, 0, 1) { SCM x; POP (x); @@ -1090,7 +1103,7 @@ VM_DEFINE_INSTRUCTION (60, tail_call_nargs, "tail-call/nargs", 0, 0, 1) goto vm_tail_call; } -VM_DEFINE_INSTRUCTION (61, call_nargs, "call/nargs", 0, 0, 1) +VM_DEFINE_INSTRUCTION (63, call_nargs, "call/nargs", 0, 0, 1) { SCM x; POP (x); @@ -1099,7 +1112,7 @@ VM_DEFINE_INSTRUCTION (61, call_nargs, "call/nargs", 0, 0, 1) goto vm_call; } -VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1) +VM_DEFINE_INSTRUCTION (64, mv_call, "mv-call", 4, -1, 1) { scm_t_int32 offset; scm_t_uint8 *mvra; @@ -1152,7 +1165,7 @@ VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (63, apply, "apply", 1, -1, 1) +VM_DEFINE_INSTRUCTION (65, apply, "apply", 1, -1, 1) { int len; SCM ls; @@ -1174,7 +1187,7 @@ VM_DEFINE_INSTRUCTION (63, apply, "apply", 1, -1, 1) goto vm_call; } -VM_DEFINE_INSTRUCTION (64, tail_apply, "tail-apply", 1, -1, 1) +VM_DEFINE_INSTRUCTION (66, tail_apply, "tail-apply", 1, -1, 1) { int len; SCM ls; @@ -1196,7 +1209,7 @@ VM_DEFINE_INSTRUCTION (64, tail_apply, "tail-apply", 1, -1, 1) goto vm_tail_call; } -VM_DEFINE_INSTRUCTION (65, call_cc, "call/cc", 0, 1, 1) +VM_DEFINE_INSTRUCTION (67, call_cc, "call/cc", 0, 1, 1) { int first; SCM proc, vm_cont, cont; @@ -1234,7 +1247,7 @@ VM_DEFINE_INSTRUCTION (65, call_cc, "call/cc", 0, 1, 1) } } -VM_DEFINE_INSTRUCTION (66, tail_call_cc, "tail-call/cc", 0, 1, 1) +VM_DEFINE_INSTRUCTION (68, tail_call_cc, "tail-call/cc", 0, 1, 1) { int first; SCM proc, vm_cont, cont; @@ -1277,7 +1290,7 @@ VM_DEFINE_INSTRUCTION (66, tail_call_cc, "tail-call/cc", 0, 1, 1) } } -VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1) +VM_DEFINE_INSTRUCTION (69, return, "return", 0, 1, 1) { vm_return: POP_CONTINUATION_HOOK (1); @@ -1313,7 +1326,7 @@ VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1) +VM_DEFINE_INSTRUCTION (70, return_values, "return/values", 1, -1, -1) { /* nvalues declared at top level, because for some reason gcc seems to think that perhaps it might be used without declaration. Fooey to that, I say. */ @@ -1369,7 +1382,7 @@ VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (69, return_values_star, "return/values*", 1, -1, -1) +VM_DEFINE_INSTRUCTION (71, return_values_star, "return/values*", 1, -1, -1) { SCM l; @@ -1392,7 +1405,7 @@ VM_DEFINE_INSTRUCTION (69, return_values_star, "return/values*", 1, -1, -1) goto vm_return_values; } -VM_DEFINE_INSTRUCTION (70, return_nvalues, "return/nvalues", 0, 1, -1) +VM_DEFINE_INSTRUCTION (72, return_nvalues, "return/nvalues", 0, 1, -1) { SCM n; POP (n); @@ -1401,7 +1414,7 @@ VM_DEFINE_INSTRUCTION (70, return_nvalues, "return/nvalues", 0, 1, -1) goto vm_return_values; } -VM_DEFINE_INSTRUCTION (71, truncate_values, "truncate-values", 2, -1, -1) +VM_DEFINE_INSTRUCTION (73, truncate_values, "truncate-values", 2, -1, -1) { SCM x; int nbinds, rest; @@ -1424,7 +1437,7 @@ VM_DEFINE_INSTRUCTION (71, truncate_values, "truncate-values", 2, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (72, box, "box", 1, 1, 0) +VM_DEFINE_INSTRUCTION (74, box, "box", 1, 1, 0) { SCM val; POP (val); @@ -1438,7 +1451,7 @@ VM_DEFINE_INSTRUCTION (72, box, "box", 1, 1, 0) (set! a (lambda () (b ...))) ...) */ -VM_DEFINE_INSTRUCTION (73, empty_box, "empty-box", 1, 0, 0) +VM_DEFINE_INSTRUCTION (75, empty_box, "empty-box", 1, 0, 0) { SYNC_BEFORE_GC (); LOCAL_SET (FETCH (), @@ -1446,7 +1459,7 @@ VM_DEFINE_INSTRUCTION (73, empty_box, "empty-box", 1, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (74, local_boxed_ref, "local-boxed-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (76, local_boxed_ref, "local-boxed-ref", 1, 0, 1) { SCM v = LOCAL_REF (FETCH ()); ASSERT_BOUND_VARIABLE (v); @@ -1454,7 +1467,7 @@ VM_DEFINE_INSTRUCTION (74, local_boxed_ref, "local-boxed-ref", 1, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (75, local_boxed_set, "local-boxed-set", 1, 1, 0) +VM_DEFINE_INSTRUCTION (77, local_boxed_set, "local-boxed-set", 1, 1, 0) { SCM v, val; v = LOCAL_REF (FETCH ()); @@ -1464,7 +1477,7 @@ VM_DEFINE_INSTRUCTION (75, local_boxed_set, "local-boxed-set", 1, 1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (76, free_ref, "free-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (78, free_ref, "free-ref", 1, 0, 1) { scm_t_uint8 idx = FETCH (); @@ -1475,7 +1488,7 @@ VM_DEFINE_INSTRUCTION (76, free_ref, "free-ref", 1, 0, 1) /* no free-set -- if a var is assigned, it should be in a box */ -VM_DEFINE_INSTRUCTION (77, free_boxed_ref, "free-boxed-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (79, free_boxed_ref, "free-boxed-ref", 1, 0, 1) { SCM v; scm_t_uint8 idx = FETCH (); @@ -1486,7 +1499,7 @@ VM_DEFINE_INSTRUCTION (77, free_boxed_ref, "free-boxed-ref", 1, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (78, free_boxed_set, "free-boxed-set", 1, 1, 0) +VM_DEFINE_INSTRUCTION (80, free_boxed_set, "free-boxed-set", 1, 1, 0) { SCM v, val; scm_t_uint8 idx = FETCH (); @@ -1498,7 +1511,7 @@ VM_DEFINE_INSTRUCTION (78, free_boxed_set, "free-boxed-set", 1, 1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (79, make_closure, "make-closure", 2, -1, 1) +VM_DEFINE_INSTRUCTION (81, make_closure, "make-closure", 2, -1, 1) { size_t n, len; SCM closure; @@ -1517,7 +1530,7 @@ VM_DEFINE_INSTRUCTION (79, make_closure, "make-closure", 2, -1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (80, make_variable, "make-variable", 0, 0, 1) +VM_DEFINE_INSTRUCTION (82, make_variable, "make-variable", 0, 0, 1) { SYNC_BEFORE_GC (); /* fixme underflow */ @@ -1525,7 +1538,7 @@ VM_DEFINE_INSTRUCTION (80, make_variable, "make-variable", 0, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (81, fix_closure, "fix-closure", 2, -1, 0) +VM_DEFINE_INSTRUCTION (83, fix_closure, "fix-closure", 2, -1, 0) { SCM x; unsigned int i = FETCH (); @@ -1542,7 +1555,7 @@ VM_DEFINE_INSTRUCTION (81, fix_closure, "fix-closure", 2, -1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2) +VM_DEFINE_INSTRUCTION (84, define, "define", 0, 0, 2) { SCM sym, val; POP2 (sym, val); @@ -1553,7 +1566,7 @@ VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2) NEXT; } -VM_DEFINE_INSTRUCTION (83, make_keyword, "make-keyword", 0, 1, 1) +VM_DEFINE_INSTRUCTION (85, make_keyword, "make-keyword", 0, 1, 1) { CHECK_UNDERFLOW (); SYNC_REGISTER (); @@ -1561,7 +1574,7 @@ VM_DEFINE_INSTRUCTION (83, make_keyword, "make-keyword", 0, 1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (84, make_symbol, "make-symbol", 0, 1, 1) +VM_DEFINE_INSTRUCTION (86, make_symbol, "make-symbol", 0, 1, 1) { CHECK_UNDERFLOW (); SYNC_REGISTER (); @@ -1569,7 +1582,7 @@ VM_DEFINE_INSTRUCTION (84, make_symbol, "make-symbol", 0, 1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0) +VM_DEFINE_INSTRUCTION (87, prompt, "prompt", 4, 2, 0) { scm_t_int32 offset; scm_t_uint8 escape_only_p; @@ -1609,7 +1622,7 @@ VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0) NEXT; } -VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0) +VM_DEFINE_INSTRUCTION (88, wind, "wind", 0, 2, 0) { SCM wind, unwind; POP2 (unwind, wind); @@ -1623,7 +1636,7 @@ VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0) NEXT; } -VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1) +VM_DEFINE_INSTRUCTION (89, abort, "abort", 1, -1, -1) { unsigned n = FETCH (); SYNC_REGISTER (); @@ -1634,7 +1647,7 @@ VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1) abort (); } -VM_DEFINE_INSTRUCTION (88, unwind, "unwind", 0, 0, 0) +VM_DEFINE_INSTRUCTION (90, unwind, "unwind", 0, 0, 0) { /* A normal exit from the dynamic extent of an expression. Pop the top entry off of the dynamic stack. */ @@ -1642,7 +1655,7 @@ VM_DEFINE_INSTRUCTION (88, unwind, "unwind", 0, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0) +VM_DEFINE_INSTRUCTION (91, wind_fluids, "wind-fluids", 1, -1, 0) { unsigned n = FETCH (); @@ -1655,7 +1668,7 @@ VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0) +VM_DEFINE_INSTRUCTION (92, unwind_fluids, "unwind-fluids", 0, 0, 0) { /* This function must not allocate. */ scm_dynstack_unwind_fluids (¤t_thread->dynstack, @@ -1663,7 +1676,7 @@ VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1) +VM_DEFINE_INSTRUCTION (93, fluid_ref, "fluid-ref", 0, 1, 1) { size_t num; SCM fluids; @@ -1693,7 +1706,7 @@ VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2, 0) +VM_DEFINE_INSTRUCTION (94, fluid_set, "fluid-set", 0, 2, 0) { size_t num; SCM val, fluid, fluids; @@ -1713,7 +1726,7 @@ VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2, 0) NEXT; } -VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0) +VM_DEFINE_INSTRUCTION (95, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0) { scm_t_ptrdiff n; SCM *old_sp; @@ -1733,7 +1746,6 @@ VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, NEXT; } - /* (defun renumber-ops () "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" diff --git a/module/Makefile.am b/module/Makefile.am index 9c9d8ed36..865bf89d2 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -135,6 +135,7 @@ ECMASCRIPT_LANG_SOURCES = \ language/ecmascript/spec.scm ELISP_LANG_SOURCES = \ + language/elisp/falias.scm \ language/elisp/lexer.scm \ language/elisp/parser.scm \ language/elisp/bindings.scm \ @@ -142,8 +143,6 @@ ELISP_LANG_SOURCES = \ language/elisp/runtime.scm \ language/elisp/runtime/function-slot.scm \ language/elisp/runtime/value-slot.scm \ - language/elisp/runtime/macros.scm \ - language/elisp/runtime/subrs.scm \ language/elisp/spec.scm BRAINFUCK_LANG_SOURCES = \ @@ -374,6 +373,9 @@ WEB_SOURCES = \ EXTRA_DIST += oop/ChangeLog-2008 +ELISP_SOURCES = \ + language/elisp/boot.el + NOCOMP_SOURCES = \ ice-9/match.upstream.scm \ ice-9/psyntax.scm \ diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index 85805a523..bd31930fb 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -133,6 +133,8 @@ ((br-if-not-eq ,l) (write-break l)) ((br-if-null ,l) (write-break l)) ((br-if-not-null ,l) (write-break l)) + ((br-if-nil ,l) (write-break l)) + ((br-if-not-nil ,l) (write-break l)) ((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l)) ((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l)) ((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l)) diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm index ced5f26a8..6ad5f7df9 100644 --- a/module/language/assembly/disassemble.scm +++ b/module/language/assembly/disassemble.scm @@ -125,7 +125,9 @@ (case inst ((list vector) (list "~a element~:p" (apply make-int16 args))) - ((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null) + ((br + br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null + br-if-nil br-if-not-nil) (list "-> ~A" (assq-ref labels (car args)))) ((br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt) (list "-> ~A" (assq-ref labels (caddr args)))) diff --git a/module/language/elisp/bindings.scm b/module/language/elisp/bindings.scm index 6ff56fdcd..9fabddfc4 100644 --- a/module/language/elisp/bindings.scm +++ b/module/language/elisp/bindings.scm @@ -19,21 +19,22 @@ ;;; Code: (define-module (language elisp bindings) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) #:export (make-bindings - mark-global-needed! - map-globals-needed with-lexical-bindings with-dynamic-bindings - get-lexical-binding)) + with-function-bindings + get-lexical-binding + get-function-binding)) ;;; This module defines routines to handle analysis of symbol bindings ;;; used during elisp compilation. This data allows to collect the ;;; symbols, for which globals need to be created, or mark certain ;;; symbols as lexically bound. ;;; -;;; Needed globals are stored in an association-list that stores a list -;;; of symbols for each module they are needed in. -;;; ;;; The lexical bindings of symbols are stored in a hash-table that ;;; associates symbols to fluids; those fluids are used in the ;;; with-lexical-binding and with-dynamic-binding routines to associate @@ -41,64 +42,32 @@ ;;; Record type used to hold the data necessary. -(define bindings-type - (make-record-type 'bindings '(needed-globals lexical-bindings))) +(define-record-type bindings + (%make-bindings lexical-bindings function-bindings) + bindings? + (lexical-bindings lexical-bindings) + (function-bindings function-bindings)) ;;; Construct an 'empty' instance of the bindings data structure to be ;;; used at the start of a fresh compilation. (define (make-bindings) - ((record-constructor bindings-type) '() (make-hash-table))) - -;;; Mark that a given symbol is needed as global in the specified -;;; slot-module. - -(define (mark-global-needed! bindings sym module) - (let* ((old-needed ((record-accessor bindings-type 'needed-globals) - bindings)) - (old-in-module (or (assoc-ref old-needed module) '())) - (new-in-module (if (memq sym old-in-module) - old-in-module - (cons sym old-in-module))) - (new-needed (assoc-set! old-needed module new-in-module))) - ((record-modifier bindings-type 'needed-globals) - bindings - new-needed))) - -;;; Cycle through all globals needed in order to generate the code for -;;; their creation or some other analysis. - -(define (map-globals-needed bindings proc) - (let ((needed ((record-accessor bindings-type 'needed-globals) - bindings))) - (let iterate-modules ((mod-tail needed) - (mod-result '())) - (if (null? mod-tail) - mod-result - (iterate-modules - (cdr mod-tail) - (let* ((aentry (car mod-tail)) - (module (car aentry)) - (symbols (cdr aentry))) - (let iterate-symbols ((sym-tail symbols) - (sym-result mod-result)) - (if (null? sym-tail) - sym-result - (iterate-symbols (cdr sym-tail) - (cons (proc module (car sym-tail)) - sym-result)))))))))) + (%make-bindings (make-hash-table) (make-hash-table))) ;;; Get the current lexical binding (gensym it should refer to in the ;;; current scope) for a symbol or #f if it is dynamically bound. (define (get-lexical-binding bindings sym) - (let* ((lex ((record-accessor bindings-type 'lexical-bindings) - bindings)) + (let* ((lex (lexical-bindings bindings)) (slot (hash-ref lex sym #f))) (if slot (fluid-ref slot) #f))) +(define (get-function-binding bindings symbol) + (and=> (hash-ref (function-bindings bindings) symbol) + fluid-ref)) + ;;; Establish a binding or mark a symbol as dynamically bound for the ;;; extent of calling proc. @@ -106,8 +75,7 @@ (if (or (not (list? syms)) (not (and-map symbol? syms))) (error "can't bind non-symbols" syms)) - (let ((lex ((record-accessor bindings-type 'lexical-bindings) - bindings))) + (let ((lex (lexical-bindings bindings))) (for-each (lambda (sym) (if (not (hash-ref lex sym)) (hash-set! lex sym (make-fluid)))) @@ -127,3 +95,13 @@ syms (map (lambda (el) #f) syms) proc)) + +(define (with-function-bindings bindings symbols gensyms thunk) + (let ((fb (function-bindings bindings))) + (for-each (lambda (symbol) + (if (not (hash-ref fb symbol)) + (hash-set! fb symbol (make-fluid)))) + symbols) + (with-fluids* (map (cut hash-ref fb <>) symbols) + gensyms + thunk))) diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el new file mode 100644 index 000000000..bec32b545 --- /dev/null +++ b/module/language/elisp/boot.el @@ -0,0 +1,495 @@ +;;; Guile Emacs Lisp -*- lexical-binding: t -*- + +;;; Copyright (C) 2011 Free Software Foundation, Inc. + +;;; This library is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;;; 02110-1301 USA + +;;; Code: + +(defmacro @ (module symbol) + `(guile-ref ,module ,symbol)) + +(defmacro eval-and-compile (&rest body) + `(progn + (eval-when-compile ,@body) + (progn ,@body))) + +(eval-and-compile + (defun null (object) + (if object nil t)) + (defun consp (object) + (%funcall (@ (guile) pair?) object)) + (defun listp (object) + (if object (consp object) t)) + (defun car (list) + (if list (%funcall (@ (guile) car) list) nil)) + (defun cdr (list) + (if list (%funcall (@ (guile) cdr) list) nil)) + (defun make-symbol (name) + (%funcall (@ (guile) make-symbol) name)) + (defun signal (error-symbol data) + (%funcall (@ (guile) throw) 'elisp-condition error-symbol data))) + +(defmacro lambda (&rest cdr) + `#'(lambda ,@cdr)) + +(defmacro prog1 (first &rest body) + (let ((temp (make-symbol "prog1-temp"))) + `(let ((,temp ,first)) + (declare (lexical ,temp)) + ,@body + ,temp))) + +(defmacro prog2 (form1 form2 &rest body) + `(progn ,form1 (prog1 ,form2 ,@body))) + +(defmacro cond (&rest clauses) + (if (null clauses) + nil + (let ((first (car clauses)) + (rest (cdr clauses))) + (if (listp first) + (let ((condition (car first)) + (body (cdr first))) + (if (null body) + (let ((temp (make-symbol "cond-temp"))) + `(let ((,temp ,condition)) + (declare (lexical ,temp)) + (if ,temp + ,temp + (cond ,@rest)))) + `(if ,condition + (progn ,@body) + (cond ,@rest)))) + (signal 'wrong-type-argument `(listp ,first)))))) + +(defmacro and (&rest conditions) + (cond ((null conditions) t) + ((null (cdr conditions)) (car conditions)) + (t `(if ,(car conditions) + (and ,@(cdr conditions)) + nil)))) + +(defmacro or (&rest conditions) + (cond ((null conditions) nil) + ((null (cdr conditions)) (car conditions)) + (t (let ((temp (make-symbol "or-temp"))) + `(let ((,temp ,(car conditions))) + (declare (lexical ,temp)) + (if ,temp + ,temp + (or ,@(cdr conditions)))))))) + +(defmacro lexical-let (bindings &rest body) + (labels ((loop (list vars) + (if (null list) + `(let ,bindings + (declare (lexical ,@vars)) + ,@body) + (loop (cdr list) + (if (consp (car list)) + `(,(car (car list)) ,@vars) + `(,(car list) ,@vars)))))) + (loop bindings '()))) + +(defmacro lexical-let* (bindings &rest body) + (labels ((loop (list vars) + (if (null list) + `(let* ,bindings + (declare (lexical ,@vars)) + ,@body) + (loop (cdr list) + (if (consp (car list)) + (cons (car (car list)) vars) + (cons (car list) vars)))))) + (loop bindings '()))) + +(defmacro while (test &rest body) + (let ((loop (make-symbol "loop"))) + `(labels ((,loop () + (if ,test + (progn ,@body (,loop)) + nil))) + (,loop)))) + +(defmacro unwind-protect (bodyform &rest unwindforms) + `(funcall (@ (guile) dynamic-wind) + #'(lambda () nil) + #'(lambda () ,bodyform) + #'(lambda () ,@unwindforms))) + +(defun symbolp (object) + (%funcall (@ (guile) symbol?) object)) + +(defun functionp (object) + (%funcall (@ (guile) procedure?) object)) + +(defun symbol-function (symbol) + (let ((f (%funcall (@ (language elisp runtime) symbol-function) + symbol))) + (if (%funcall (@ (language elisp falias) falias?) f) + (%funcall (@ (language elisp falias) falias-object) f) + f))) + +(defun eval (form) + (%funcall (@ (system base compile) compile) + form + (%funcall (@ (guile) symbol->keyword) 'from) + 'elisp + (%funcall (@ (guile) symbol->keyword) 'to) + 'value)) + +(defun %indirect-function (object) + (cond + ((functionp object) + object) + ((symbolp object) ;++ cycle detection + (%indirect-function (symbol-function object))) + ((listp object) + (eval `(function ,object))) + (t + (signal 'invalid-function `(,object))))) + +(defun apply (function &rest arguments) + (%funcall (@ (guile) apply) + (@ (guile) apply) + (%indirect-function function) + arguments)) + +(defun funcall (function &rest arguments) + (%funcall (@ (guile) apply) + (%indirect-function function) + arguments)) + +(defun fset (symbol definition) + (funcall (@ (language elisp runtime) set-symbol-function!) + symbol + (if (functionp definition) + definition + (funcall (@ (language elisp falias) make-falias) + #'(lambda (&rest args) (apply definition args)) + definition))) + definition) + +(defun load (file) + (funcall (@ (system base compile) compile-file) + file + (funcall (@ (guile) symbol->keyword) 'from) + 'elisp + (funcall (@ (guile) symbol->keyword) 'to) + 'value) + t) + +;;; Equality predicates + +(defun eq (obj1 obj2) + (if obj1 + (funcall (@ (guile) eq?) obj1 obj2) + (null obj2))) + +(defun eql (obj1 obj2) + (if obj1 + (funcall (@ (guile) eqv?) obj1 obj2) + (null obj2))) + +(defun equal (obj1 obj2) + (if obj1 + (funcall (@ (guile) equal?) obj1 obj2) + (null obj2))) + +;;; Symbols + +;;; `symbolp' and `symbol-function' are defined above. + +(fset 'symbol-value (@ (language elisp runtime) symbol-value)) +(fset 'set (@ (language elisp runtime) set-symbol-value!)) +(fset 'makunbound (@ (language elisp runtime) makunbound!)) +(fset 'fmakunbound (@ (language elisp runtime) fmakunbound!)) +(fset 'boundp (@ (language elisp runtime) symbol-bound?)) +(fset 'fboundp (@ (language elisp runtime) symbol-fbound?)) + +(defun defvaralias (new-alias base-variable &optional docstring) + (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid) + base-variable))) + (funcall (@ (language elisp runtime) set-symbol-fluid!) + new-alias + fluid) + base-variable)) + +;;; Numerical type predicates + +(defun floatp (object) + (and (funcall (@ (guile) real?) object) + (or (funcall (@ (guile) inexact?) object) + (null (funcall (@ (guile) integer?) object))))) + +(defun integerp (object) + (and (funcall (@ (guile) exact?) object) + (funcall (@ (guile) integer?) object))) + +(defun numberp (object) + (funcall (@ (guile) real?) object)) + +(defun wholenump (object) + (and (funcall (@ (guile) exact?) object) + (funcall (@ (guile) integer?) object) + (>= object 0))) + +(defun zerop (object) + (= object 0)) + +;;; Numerical comparisons + +(fset '= (@ (guile) =)) + +(defun /= (num1 num2) + (null (= num1 num2))) + +(fset '< (@ (guile) <)) +(fset '<= (@ (guile) <=)) +(fset '> (@ (guile) >)) +(fset '>= (@ (guile) >=)) + +(defun max (&rest numbers) + (apply (@ (guile) max) numbers)) + +(defun min (&rest numbers) + (apply (@ (guile) min) numbers)) + +;;; Arithmetic functions + +(fset '1+ (@ (guile) 1+)) +(fset '1- (@ (guile) 1-)) +(fset '+ (@ (guile) +)) +(fset '- (@ (guile) -)) +(fset '* (@ (guile) *)) +(fset '% (@ (guile) modulo)) +(fset 'abs (@ (guile) abs)) + +;;; Floating-point rounding + +(fset 'ffloor (@ (guile) floor)) +(fset 'fceiling (@ (guile) ceiling)) +(fset 'ftruncate (@ (guile) truncate)) +(fset 'fround (@ (guile) round)) + +;;; Numeric conversion + +(defun float (arg) + (if (numberp arg) + (funcall (@ (guile) exact->inexact) arg) + (signal 'wrong-type-argument `(numberp ,arg)))) + +;;; List predicates + +(fset 'not #'null) + +(defun atom (object) + (null (consp object))) + +(defun nlistp (object) + (null (listp object))) + +;;; Lists + +(fset 'cons (@ (guile) cons)) +(fset 'list (@ (guile) list)) +(fset 'make-list (@ (guile) make-list)) +(fset 'append (@ (guile) append)) +(fset 'reverse (@ (guile) reverse)) + +(defun car-safe (object) + (if (consp object) + (car object) + nil)) + +(defun cdr-safe (object) + (if (consp object) + (cdr object) + nil)) + +(defun setcar (cell newcar) + (if (consp cell) + (progn + (funcall (@ (guile) set-car!) cell newcar) + newcar) + (signal 'wrong-type-argument `(consp ,cell)))) + +(defun setcdr (cell newcdr) + (if (consp cell) + (progn + (funcall (@ (guile) set-cdr!) cell newcdr) + newcdr) + (signal 'wrong-type-argument `(consp ,cell)))) + +(defun nthcdr (n list) + (let ((i 0)) + (while (< i n) + (setq list (cdr list) + i (+ i 1))) + list)) + +(defun nth (n list) + (car (nthcdr n list))) + +(defun %member (elt list test) + (cond + ((null list) nil) + ((consp list) + (if (funcall test elt (car list)) + list + (%member elt (cdr list) test))) + (t (signal 'wrong-type-argument `(listp ,list))))) + +(defun member (elt list) + (%member elt list #'equal)) + +(defun memql (elt list) + (%member elt list #'eql)) + +(defun memq (elt list) + (%member elt list #'eq)) + +;;; Strings + +(defun string (&rest characters) + (funcall (@ (guile) list->string) + (mapcar (@ (guile) integer->char) characters))) + +;;; Sequences + +(fset 'length (@ (guile) length)) + +(defun mapcar (function sequence) + (funcall (@ (guile) map) function sequence)) + +;;; Property lists + +(defun %plist-member (plist property test) + (cond + ((null plist) nil) + ((consp plist) + (if (funcall test (car plist) property) + (cdr plist) + (%plist-member (cdr (cdr plist)) property test))) + (t (signal 'wrong-type-argument `(listp ,plist))))) + +(defun %plist-get (plist property test) + (car (%plist-member plist property test))) + +(defun %plist-put (plist property value test) + (let ((x (%plist-member plist property test))) + (if x + (progn (setcar x value) plist) + (cons property (cons value plist))))) + +(defun plist-get (plist property) + (%plist-get plist property #'eq)) + +(defun plist-put (plist property value) + (%plist-put plist property value #'eq)) + +(defun plist-member (plist property) + (%plist-member plist property #'eq)) + +(defun lax-plist-get (plist property) + (%plist-get plist property #'equal)) + +(defun lax-plist-put (plist property value) + (%plist-put plist property value #'equal)) + +(defvar plist-function (funcall (@ (guile) make-object-property))) + +(defun symbol-plist (symbol) + (funcall plist-function symbol)) + +(defun setplist (symbol plist) + (funcall (funcall (@ (guile) setter) plist-function) symbol plist)) + +(defun get (symbol propname) + (plist-get (symbol-plist symbol) propname)) + +(defun put (symbol propname value) + (setplist symbol (plist-put (symbol-plist symbol) propname value))) + +;;; Nonlocal exits + +(defmacro condition-case (var bodyform &rest handlers) + (let ((key (make-symbol "key")) + (error-symbol (make-symbol "error-symbol")) + (data (make-symbol "data")) + (conditions (make-symbol "conditions"))) + (flet ((handler->cond-clause (handler) + `((or ,@(mapcar #'(lambda (c) `(memq ',c ,conditions)) + (if (consp (car handler)) + (car handler) + (list (car handler))))) + ,@(cdr handler)))) + `(funcall (@ (guile) catch) + 'elisp-condition + #'(lambda () ,bodyform) + #'(lambda (,key ,error-symbol ,data) + (declare (lexical ,key ,error-symbol ,data)) + (let ((,conditions + (get ,error-symbol 'error-conditions)) + ,@(if var + `((,var (cons ,error-symbol ,data))) + '())) + (declare (lexical ,conditions + ,@(if var `(,var) '()))) + (cond ,@(mapcar #'handler->cond-clause handlers) + (t (signal ,error-symbol ,data))))))))) + +(put 'error 'error-conditions '(error)) +(put 'wrong-type-argument 'error-conditions '(wrong-type-argument error)) +(put 'invalid-function 'error-conditions '(invalid-function error)) +(put 'no-catch 'error-conditions '(no-catch error)) +(put 'throw 'error-conditions '(throw)) + +(defvar %catch nil) + +(defmacro catch (tag &rest body) + (let ((tag-value (make-symbol "tag-value")) + (c (make-symbol "c")) + (data (make-symbol "data"))) + `(let ((,tag-value ,tag)) + (declare (lexical ,tag-value)) + (condition-case ,c + (let ((%catch t)) + ,@body) + (throw + (let ((,data (cdr ,c))) + (declare (lexical ,data)) + (if (eq (car ,data) ,tag-value) + (car (cdr ,data)) + (apply #'throw ,data)))))))) + +(defun throw (tag value) + (signal (if %catch 'throw 'no-catch) (list tag value))) + +;;; I/O + +(defun princ (object) + (funcall (@ (guile) display) object)) + +(defun print (object) + (funcall (@ (guile) write) object)) + +(defun terpri () + (funcall (@ (guile) newline))) + +(defun format* (stream string &rest args) + (apply (@ (guile) format) stream string args)) diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm index e1d75ba7a..293495495 100644 --- a/module/language/elisp/compile-tree-il.scm +++ b/module/language/elisp/compile-tree-il.scm @@ -31,26 +31,24 @@ #: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 @@ -61,14 +59,7 @@ (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. @@ -117,419 +108,246 @@ (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 + (list->seq + loc + `(,@(map + (lambda (name) + (ensure-fluid! value-slot 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-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 @@ -547,12 +365,11 @@ ;;; 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)))) @@ -608,52 +425,34 @@ 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))) + (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-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 @@ -678,7 +477,7 @@ (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) @@ -696,47 +495,141 @@ (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 @@ -756,58 +649,12 @@ ((,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 @@ -817,17 +664,19 @@ (let* ((tree-il (make-seq loc - (set-variable! + (set-function! loc name - function-slot - (make-primcall loc 'cons - (list (make-const loc 'macro) - (compile-lambda loc args body)))) + (make-call + loc + (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) @@ -836,10 +685,10 @@ (if (not (symbol? name)) (report-error loc "expected symbol as function name" name) (make-seq loc - (set-variable! loc + (set-function! loc name - function-slot (compile-lambda loc + `((name . ,name)) args body)) (make-const loc name)))))) @@ -854,6 +703,19 @@ ((,val) (make-const loc val)))) +(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) @@ -867,13 +729,7 @@ => (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. @@ -882,7 +738,7 @@ (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. @@ -912,28 +768,14 @@ (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)) diff --git a/module/language/elisp/falias.scm b/module/language/elisp/falias.scm new file mode 100644 index 000000000..f043548fb --- /dev/null +++ b/module/language/elisp/falias.scm @@ -0,0 +1,27 @@ +(define-module (language elisp falias) + #:export (falias? + make-falias + falias-function + falias-object)) + +(define <falias-vtable> + (make-struct <applicable-struct-vtable> + 0 + (make-struct-layout "pwpw") + (lambda (object port) + (format port "#<falias ~S>" (falias-object object))))) + +(set-struct-vtable-name! <falias-vtable> 'falias) + +(define (falias? object) + (and (struct? object) + (eq? (struct-vtable object) <falias-vtable>))) + +(define (make-falias f object) + (make-struct <falias-vtable> 0 f object)) + +(define (falias-function object) + (struct-ref object 0)) + +(define (falias-object object) + (struct-ref object 1)) diff --git a/module/language/elisp/lexer.scm b/module/language/elisp/lexer.scm index af7e02add..1933ff34d 100644 --- a/module/language/elisp/lexer.scm +++ b/module/language/elisp/lexer.scm @@ -252,7 +252,15 @@ ;;; Main lexer routine, which is given a port and does look for the next ;;; token. +(define lexical-binding-regexp + (make-regexp + "-\\*-(|.*;)[ \t]*lexical-binding:[ \t]*([^;]*[^ \t;]).*-\\*-")) + (define (lex port) + (define (lexical-binding-value string) + (and=> (regexp-exec lexical-binding-regexp string) + (lambda (match) + (not (member (match:substring match 2) '("nil" "()")))))) (let ((return (let ((file (if (file-port? port) (port-filename port) #f)) @@ -283,11 +291,19 @@ (case c ;; A line comment, skip until end-of-line is found. ((#\;) - (let iterate () - (let ((cur (read-char port))) - (if (or (eof-object? cur) (char=? cur #\newline)) - (lex port) - (iterate))))) + (if (= (port-line port) 0) + (let iterate ((chars '())) + (let ((cur (read-char port))) + (if (or (eof-object? cur) (char=? cur #\newline)) + (let ((string (list->string (reverse chars)))) + (return 'set-lexical-binding-mode! + (lexical-binding-value string))) + (iterate (cons cur chars))))) + (let iterate () + (let ((cur (read-char port))) + (if (or (eof-object? cur) (char=? cur #\newline)) + (lex port) + (iterate)))))) ;; A character literal. ((#\?) (return 'character (get-character port #f))) @@ -321,7 +337,12 @@ (let ((mark (get-circular-marker port))) (return (car mark) (cdr mark)))) ((#\') - (return 'function #f))))) + (return 'function #f)) + ((#\:) + (call-with-values + (lambda () (get-symbol-or-number port)) + (lambda (type str) + (return 'symbol (make-symbol str)))))))) ;; Parentheses and other special-meaning single characters. ((#\() (return 'paren-open #f)) ((#\)) (return 'paren-close #f)) diff --git a/module/language/elisp/parser.scm b/module/language/elisp/parser.scm index df825eb4e..e83f136bb 100644 --- a/module/language/elisp/parser.scm +++ b/module/language/elisp/parser.scm @@ -201,6 +201,8 @@ (setter expr) (force-promises! expr) expr)) + ((set-lexical-binding-mode!) + (return `(%set-lexical-binding-mode ,(cdr token)))) (else (parse-error token "expected expression, got" token))))) diff --git a/module/language/elisp/runtime.scm b/module/language/elisp/runtime.scm index 0c84d102b..6f6a22074 100644 --- a/module/language/elisp/runtime.scm +++ b/module/language/elisp/runtime.scm @@ -25,11 +25,17 @@ function-slot-module elisp-bool ensure-fluid! - reference-variable - set-variable! - runtime-error - macro-error) - #:export-syntax (built-in-func built-in-macro defspecial prim)) + symbol-fluid + set-symbol-fluid! + symbol-value + set-symbol-value! + symbol-function + set-symbol-function! + symbol-bound? + symbol-fbound? + makunbound! + fmakunbound!) + #:export-syntax (defspecial prim)) ;;; This module provides runtime support for the Elisp front-end. @@ -47,22 +53,6 @@ (define function-slot-module '(language elisp runtime function-slot)) -;;; Report an error during macro compilation, that means some special -;;; compilation (syntax) error; or report a simple runtime-error from a -;;; built-in function. - -(define (macro-error msg . args) - (apply error msg args)) - -(define runtime-error macro-error) - -;;; Convert a scheme boolean to Elisp. - -(define (elisp-bool b) - (if b - t-value - nil-value)) - ;;; Routines for access to elisp dynamically bound symbols. This is ;;; used for runtime access using functions like symbol-value or set, ;;; where the symbol accessed might not be known at compile-time. These @@ -77,39 +67,68 @@ (module-define! resolved sym fluid) (module-export! resolved `(,sym)))))) -(define (reference-variable module sym) - (let ((resolved (resolve-module module))) - (cond - ((equal? module function-slot-module) - (module-ref resolved sym)) - (else - (ensure-fluid! module sym) - (fluid-ref (module-ref resolved sym)))))) +(define (symbol-fluid symbol) + (let ((module (resolve-module value-slot-module))) + (ensure-fluid! value-slot-module symbol) ;++ implicit special proclamation + (module-ref module symbol))) -(define (set-variable! module sym value) - (let ((intf (resolve-interface module)) - (resolved (resolve-module module))) - (cond - ((equal? module function-slot-module) - (cond - ((module-defined? intf sym) - (module-set! resolved sym value)) - (else - (module-define! resolved sym value) - (module-export! resolved `(,sym))))) - (else - (ensure-fluid! module sym) - (fluid-set! (module-ref resolved sym) value)))) +(define (set-symbol-fluid! symbol fluid) + (let ((module (resolve-module value-slot-module))) + (module-define! module symbol fluid) + (module-export! module (list symbol))) + fluid) + +(define (symbol-value symbol) + (fluid-ref (symbol-fluid symbol))) + +(define (set-symbol-value! symbol value) + (fluid-set! (symbol-fluid symbol) value) value) -;;; Define a predefined function or predefined macro for use in the -;;; function-slot and macro-slot modules, respectively. +(define (symbol-function symbol) + (let ((module (resolve-module function-slot-module))) + (module-ref module symbol))) + +(define (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 @@ -125,30 +144,10 @@ datum)) data))))) -(define-syntax built-in-macro - (lambda (x) - (syntax-case x () - ((_ name value) - (with-syntax ((scheme-name (make-id #'name 'macro- #'name))) - #'(begin - (define-public scheme-name - (make-fluid (cons 'macro value))))))))) - (define-syntax defspecial (lambda (x) (syntax-case x () ((_ name args body ...) (with-syntax ((scheme-name (make-id #'name 'compile- #'name))) - #'(begin - (define scheme-name - (make-fluid - (cons 'special-operator - (lambda args body ...)))))))))) - -;;; Call a guile-primitive that may be rebound for elisp and thus needs -;;; absolute addressing. - -(define-syntax prim - (syntax-rules () - ((_ sym args ...) - ((@ (guile) sym) args ...)))) + #'(define scheme-name + (cons 'special-operator (lambda args body ...)))))))) diff --git a/module/language/elisp/runtime/function-slot.scm b/module/language/elisp/runtime/function-slot.scm index 896e3cece..3b10205c1 100644 --- a/module/language/elisp/runtime/function-slot.scm +++ b/module/language/elisp/runtime/function-slot.scm @@ -17,142 +17,47 @@ ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (language elisp runtime function-slot) - #:use-module (language elisp runtime subrs) - #:use-module ((language elisp runtime macros) - #:select - ((macro-lambda . lambda) - (macro-prog1 . prog1) - (macro-prog2 . prog2) - (macro-when . when) - (macro-unless . unless) - (macro-cond . cond) - (macro-and . and) - (macro-or . or) - (macro-dotimes . dotimes) - (macro-dolist . dolist) - (macro-catch . catch) - (macro-unwind-protect . unwind-protect) - (macro-pop . pop) - (macro-push . push))) #:use-module ((language elisp compile-tree-il) #:select ((compile-progn . progn) + (compile-eval-when-compile . eval-when-compile) (compile-if . if) (compile-defconst . defconst) (compile-defvar . defvar) (compile-setq . setq) (compile-let . let) - (compile-lexical-let . lexical-let) (compile-flet . flet) + (compile-labels . labels) (compile-let* . let*) - (compile-lexical-let* . lexical-let*) - (compile-flet* . flet*) - (compile-with-always-lexical . with-always-lexical) (compile-guile-ref . guile-ref) (compile-guile-primitive . guile-primitive) - (compile-while . while) (compile-function . function) (compile-defun . defun) (compile-defmacro . defmacro) (#{compile-`}# . #{`}#) - (compile-quote . quote))) + (compile-quote . quote) + (compile-%funcall . %funcall) + (compile-%set-lexical-binding-mode + . %set-lexical-binding-mode))) #:duplicates (last) ;; special operators #:re-export (progn + eval-when-compile if defconst defvar setq let - lexical-let flet + labels let* - lexical-let* - flet* - with-always-lexical guile-ref guile-primitive - while function defun defmacro #{`}# - quote) - ;; macros - #:re-export (lambda - prog1 - prog2 - when - unless - cond - and - or - dotimes - dolist - catch - unwind-protect - pop - push) - ;; functions - #:re-export (eq - equal - floatp - integerp - numberp - wholenump - zerop - = - /= - < - <= - > - >= - max - min - abs - float - 1+ - 1- - + - - - * - % - ffloor - fceiling - ftruncate - fround - consp - atomp - listp - nlistp - null - car - cdr - car-safe - cdr-safe - nth - nthcdr - length - cons - list - make-list - append - reverse - copy-tree - number-sequence - setcar - setcdr - symbol-value - symbol-function - set - fset - makunbound - fmakunbound - boundp - fboundp - apply - funcall - throw - not - eval - load)) + quote + %funcall + %set-lexical-binding-mode) + #:pure) diff --git a/module/language/elisp/runtime/macros.scm b/module/language/elisp/runtime/macros.scm deleted file mode 100644 index b28706781..000000000 --- a/module/language/elisp/runtime/macros.scm +++ /dev/null @@ -1,208 +0,0 @@ -;;; Guile Emacs Lisp - -;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. -;;; -;;; This library is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 3 of the License, or (at your option) any later version. -;;; -;;; This library is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this library; if not, write to the Free Software -;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Code: - -(define-module (language elisp runtime macros) - #:use-module (language elisp runtime)) - -;;; This module contains the macro definitions of elisp symbols. In -;;; contrast to the other runtime modules, those are used directly -;;; during compilation, of course, so not really in runtime. But I -;;; think it fits well to the others here. - -(built-in-macro lambda - (lambda cdr - `(function (lambda ,@cdr)))) - -;;; The prog1 and prog2 constructs can easily be defined as macros using -;;; progn and some lexical-let's to save the intermediate value to -;;; return at the end. - -(built-in-macro prog1 - (lambda (form1 . rest) - (let ((temp (gensym))) - `(lexical-let ((,temp ,form1)) - ,@rest - ,temp)))) - -(built-in-macro prog2 - (lambda (form1 form2 . rest) - `(progn ,form1 (prog1 ,form2 ,@rest)))) - -;;; Define the conditionals when and unless as macros. - -(built-in-macro when - (lambda (condition . thens) - `(if ,condition (progn ,@thens) nil))) - -(built-in-macro unless - (lambda (condition . elses) - `(if ,condition nil (progn ,@elses)))) - -;;; Impement the cond form as nested if's. A special case is a -;;; (condition) subform, in which case we need to return the condition -;;; itself if it is true and thus save it in a local variable before -;;; testing it. - -(built-in-macro cond - (lambda (. clauses) - (let iterate ((tail clauses)) - (if (null? tail) - 'nil - (let ((cur (car tail)) - (rest (iterate (cdr tail)))) - (prim cond - ((prim or (not (list? cur)) (null? cur)) - (macro-error "invalid clause in cond" cur)) - ((null? (cdr cur)) - (let ((var (gensym))) - `(lexical-let ((,var ,(car cur))) - (if ,var - ,var - ,rest)))) - (else - `(if ,(car cur) - (progn ,@(cdr cur)) - ,rest)))))))) - -;;; The `and' and `or' forms can also be easily defined with macros. - -(built-in-macro and - (case-lambda - (() 't) - ((x) x) - ((x . args) - (let iterate ((x x) (tail args)) - (if (null? tail) - x - `(if ,x - ,(iterate (car tail) (cdr tail)) - nil)))))) - -(built-in-macro or - (case-lambda - (() 'nil) - ((x) x) - ((x . args) - (let iterate ((x x) (tail args)) - (if (null? tail) - x - (let ((var (gensym))) - `(lexical-let ((,var ,x)) - (if ,var - ,var - ,(iterate (car tail) (cdr tail)))))))))) - -;;; Define the dotimes and dolist iteration macros. - -(built-in-macro dotimes - (lambda (args . body) - (if (prim or - (not (list? args)) - (< (length args) 2) - (> (length args) 3)) - (macro-error "invalid dotimes arguments" args) - (let ((var (car args)) - (count (cadr args))) - (if (not (symbol? var)) - (macro-error "expected symbol as dotimes variable")) - `(let ((,var 0)) - (while ((guile-primitive <) ,var ,count) - ,@body - (setq ,var ((guile-primitive 1+) ,var))) - ,@(if (= (length args) 3) - (list (caddr args)) - '())))))) - -(built-in-macro dolist - (lambda (args . body) - (if (prim or - (not (list? args)) - (< (length args) 2) - (> (length args) 3)) - (macro-error "invalid dolist arguments" args) - (let ((var (car args)) - (iter-list (cadr args)) - (tailvar (gensym))) - (if (not (symbol? var)) - (macro-error "expected symbol as dolist variable") - `(let (,var) - (lexical-let ((,tailvar ,iter-list)) - (while ((guile-primitive not) - ((guile-primitive null?) ,tailvar)) - (setq ,var ((guile-primitive car) ,tailvar)) - ,@body - (setq ,tailvar ((guile-primitive cdr) ,tailvar))) - ,@(if (= (length args) 3) - (list (caddr args)) - '())))))))) - -;;; Exception handling. unwind-protect and catch are implemented as -;;; macros (throw is a built-in function). - -;;; catch and throw can mainly be implemented directly using Guile's -;;; primitives for exceptions, the only difficulty is that the keys used -;;; within Guile must be symbols, while elisp allows any value and -;;; checks for matches using eq (eq?). We handle this by using always #t -;;; as key for the Guile primitives and check for matches inside the -;;; handler; if the elisp keys are not eq?, we rethrow the exception. - -(built-in-macro catch - (lambda (tag . body) - (if (null? body) - (macro-error "catch with empty body")) - (let ((tagsym (gensym))) - `(lexical-let ((,tagsym ,tag)) - ((guile-primitive catch) - #t - (lambda () ,@body) - ,(let* ((dummy-key (gensym)) - (elisp-key (gensym)) - (value (gensym)) - (arglist `(,dummy-key ,elisp-key ,value))) - `(with-always-lexical - ,arglist - (lambda ,arglist - (if (eq ,elisp-key ,tagsym) - ,value - ((guile-primitive throw) ,dummy-key ,elisp-key - ,value)))))))))) - -;;; unwind-protect is just some weaker construct as dynamic-wind, so -;;; straight-forward to implement. - -(built-in-macro unwind-protect - (lambda (body . clean-ups) - (if (null? clean-ups) - (macro-error "unwind-protect without cleanup code")) - `((guile-primitive dynamic-wind) - (lambda () nil) - (lambda () ,body) - (lambda () ,@clean-ups)))) - -;;; Pop off the first element from a list or push one to it. - -(built-in-macro pop - (lambda (list-name) - `(prog1 (car ,list-name) - (setq ,list-name (cdr ,list-name))))) - -(built-in-macro push - (lambda (new-el list-name) - `(setq ,list-name (cons ,new-el ,list-name)))) diff --git a/module/language/elisp/runtime/subrs.scm b/module/language/elisp/runtime/subrs.scm deleted file mode 100644 index b03a510a1..000000000 --- a/module/language/elisp/runtime/subrs.scm +++ /dev/null @@ -1,383 +0,0 @@ -;;; Guile Emacs Lisp - -;;; Copyright (C) 2009 Free Software Foundation, Inc. -;;; -;;; This library is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This library is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this library; if not, write to the Free Software -;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -;;; 02110-1301 USA - -;;; Code: - -(define-module (language elisp runtime subrs) - #:use-module (language elisp runtime) - #:use-module (system base compile)) - -;;; This module contains the function-slots of elisp symbols. Elisp -;;; built-in functions are implemented as predefined function bindings -;;; here. - -;;; Equivalence and equalness predicates. - -(built-in-func eq - (lambda (a b) - (elisp-bool (eq? a b)))) - -(built-in-func equal - (lambda (a b) - (elisp-bool (equal? a b)))) - -;;; Number predicates. - -(built-in-func floatp - (lambda (num) - (elisp-bool (and (real? num) - (or (inexact? num) - (prim not (integer? num))))))) - -(built-in-func integerp - (lambda (num) - (elisp-bool (and (exact? num) - (integer? num))))) - -(built-in-func numberp - (lambda (num) - (elisp-bool (real? num)))) - -(built-in-func wholenump - (lambda (num) - (elisp-bool (and (exact? num) - (integer? num) - (prim >= num 0))))) - -(built-in-func zerop - (lambda (num) - (elisp-bool (prim = num 0)))) - -;;; Number comparisons. - -(built-in-func = - (lambda (num1 num2) - (elisp-bool (prim = num1 num2)))) - -(built-in-func /= - (lambda (num1 num2) - (elisp-bool (prim not (prim = num1 num2))))) - -(built-in-func < - (lambda (num1 num2) - (elisp-bool (prim < num1 num2)))) - -(built-in-func <= - (lambda (num1 num2) - (elisp-bool (prim <= num1 num2)))) - -(built-in-func > - (lambda (num1 num2) - (elisp-bool (prim > num1 num2)))) - -(built-in-func >= - (lambda (num1 num2) - (elisp-bool (prim >= num1 num2)))) - -(built-in-func max - (lambda (. nums) - (prim apply (@ (guile) max) nums))) - -(built-in-func min - (lambda (. nums) - (prim apply (@ (guile) min) nums))) - -(built-in-func abs - (@ (guile) abs)) - -;;; Number conversion. - -(built-in-func float - (lambda (num) - (if (exact? num) - (exact->inexact num) - num))) - -;;; TODO: truncate, floor, ceiling, round. - -;;; Arithmetic functions. - -(built-in-func 1+ (@ (guile) 1+)) - -(built-in-func 1- (@ (guile) 1-)) - -(built-in-func + (@ (guile) +)) - -(built-in-func - (@ (guile) -)) - -(built-in-func * (@ (guile) *)) - -(built-in-func % (@ (guile) modulo)) - -;;; TODO: / with correct integer/real behaviour, mod (for floating-piont -;;; values). - -;;; Floating-point rounding operations. - -(built-in-func ffloor (@ (guile) floor)) - -(built-in-func fceiling (@ (guile) ceiling)) - -(built-in-func ftruncate (@ (guile) truncate)) - -(built-in-func fround (@ (guile) round)) - -;;; List predicates. - -(built-in-func consp - (lambda (el) - (elisp-bool (pair? el)))) - -(built-in-func atomp - (lambda (el) - (elisp-bool (prim not (pair? el))))) - -(built-in-func listp - (lambda (el) - (elisp-bool (or (pair? el) (null? el))))) - -(built-in-func nlistp - (lambda (el) - (elisp-bool (and (prim not (pair? el)) - (prim not (null? el)))))) - -(built-in-func null - (lambda (el) - (elisp-bool (null? el)))) - -;;; Accessing list elements. - -(built-in-func car - (lambda (el) - (if (null? el) - nil-value - (prim car el)))) - -(built-in-func cdr - (lambda (el) - (if (null? el) - nil-value - (prim cdr el)))) - -(built-in-func car-safe - (lambda (el) - (if (pair? el) - (prim car el) - nil-value))) - -(built-in-func cdr-safe - (lambda (el) - (if (pair? el) - (prim cdr el) - nil-value))) - -(built-in-func nth - (lambda (n lst) - (if (negative? n) - (prim car lst) - (let iterate ((i n) - (tail lst)) - (cond - ((null? tail) nil-value) - ((zero? i) (prim car tail)) - (else (iterate (prim 1- i) (prim cdr tail)))))))) - -(built-in-func nthcdr - (lambda (n lst) - (if (negative? n) - lst - (let iterate ((i n) - (tail lst)) - (cond - ((null? tail) nil-value) - ((zero? i) tail) - (else (iterate (prim 1- i) (prim cdr tail)))))))) - -(built-in-func length (@ (guile) length)) - -;;; Building lists. - -(built-in-func cons (@ (guile) cons)) - -(built-in-func list (@ (guile) list)) - -(built-in-func make-list - (lambda (len obj) - (prim make-list len obj))) - -(built-in-func append (@ (guile) append)) - -(built-in-func reverse (@ (guile) reverse)) - -(built-in-func copy-tree (@ (guile) copy-tree)) - -(built-in-func number-sequence - (lambda (from . rest) - (if (prim > (prim length rest) 2) - (runtime-error "too many arguments for number-sequence" - (prim cdddr rest)) - (if (null? rest) - `(,from) - (let ((to (prim car rest)) - (sep (if (or (null? (prim cdr rest)) - (eq? nil-value (prim cadr rest))) - 1 - (prim cadr rest)))) - (cond - ((or (eq? nil-value to) (prim = to from)) `(,from)) - ((and (zero? sep) (prim not (prim = from to))) - (runtime-error "infinite list in number-sequence")) - ((prim < (prim * to sep) (prim * from sep)) '()) - (else - (let iterate ((i (prim + - from - (prim * - sep - (prim quotient - (prim abs - (prim - - to - from)) - (prim abs sep))))) - (result '())) - (if (prim = i from) - (prim cons i result) - (iterate (prim - i sep) - (prim cons i result))))))))))) - -;;; Changing lists. - -(built-in-func setcar - (lambda (cell val) - (if (and (null? cell) (null? val)) - #nil - (prim set-car! cell val)) - val)) - -(built-in-func setcdr - (lambda (cell val) - (if (and (null? cell) (null? val)) - #nil - (prim set-cdr! cell val)) - val)) - -;;; Accessing symbol bindings for symbols known only at runtime. - -(built-in-func symbol-value - (lambda (sym) - (reference-variable value-slot-module sym))) - -(built-in-func symbol-function - (lambda (sym) - (reference-variable function-slot-module sym))) - -(built-in-func set - (lambda (sym value) - (set-variable! value-slot-module sym value))) - -(built-in-func fset - (lambda (sym value) - (set-variable! function-slot-module sym value))) - -(built-in-func makunbound - (lambda (sym) - (if (module-bound? (resolve-interface value-slot-module) sym) - (let ((var (module-variable (resolve-module value-slot-module) - sym))) - (if (and (variable-bound? var) (fluid? (variable-ref var))) - (fluid-unset! (variable-ref var)) - (variable-unset! var)))) - sym)) - -(built-in-func fmakunbound - (lambda (sym) - (if (module-bound? (resolve-interface function-slot-module) sym) - (let ((var (module-variable - (resolve-module function-slot-module) - sym))) - (if (and (variable-bound? var) (fluid? (variable-ref var))) - (fluid-unset! (variable-ref var)) - (variable-unset! var)))) - sym)) - -(built-in-func boundp - (lambda (sym) - (elisp-bool - (and - (module-bound? (resolve-interface value-slot-module) sym) - (let ((var (module-variable (resolve-module value-slot-module) - sym))) - (and (variable-bound? var) - (if (fluid? (variable-ref var)) - (fluid-bound? (variable-ref var)) - #t))))))) - -(built-in-func fboundp - (lambda (sym) - (elisp-bool - (and - (module-bound? (resolve-interface function-slot-module) sym) - (let* ((var (module-variable (resolve-module function-slot-module) - sym))) - (and (variable-bound? var) - (if (fluid? (variable-ref var)) - (fluid-bound? (variable-ref var)) - #t))))))) - -;;; Function calls. These must take care of special cases, like using -;;; symbols or raw lambda-lists as functions! - -(built-in-func apply - (lambda (func . args) - (let ((real-func (cond - ((symbol? func) - (reference-variable function-slot-module func)) - ((list? func) - (if (and (prim not (null? func)) - (eq? (prim car func) 'lambda)) - (compile func #:from 'elisp #:to 'value) - (runtime-error "list is not a function" - func))) - (else func)))) - (prim apply (@ (guile) apply) real-func args)))) - -(built-in-func funcall - (lambda (func . args) - (apply func args))) - -;;; Throw can be implemented as built-in function. - -(built-in-func throw - (lambda (tag value) - (prim throw 'elisp-exception tag value))) - -;;; Miscellaneous. - -(built-in-func not - (lambda (x) - (if x nil-value t-value))) - -(built-in-func eval - (lambda (form) - (compile form #:from 'elisp #:to 'value))) - -(built-in-func load - (lambda* (file) - (compile-file file #:from 'elisp #:to 'value) - #t)) diff --git a/module/language/elisp/runtime/value-slot.scm b/module/language/elisp/runtime/value-slot.scm index c6cc3b46f..c2f3666cc 100644 --- a/module/language/elisp/runtime/value-slot.scm +++ b/module/language/elisp/runtime/value-slot.scm @@ -18,6 +18,7 @@ ;;; Code: -(define-module (language elisp runtime value-slot)) +(define-module (language elisp runtime value-slot) + #:pure) ;;; This module contains the value-slots of elisp symbols. diff --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm index 3da368093..38a32c2df 100644 --- a/module/language/elisp/spec.scm +++ b/module/language/elisp/spec.scm @@ -22,6 +22,7 @@ #:use-module (language elisp compile-tree-il) #:use-module (language elisp parser) #:use-module (system base language) + #:use-module (system base compile) #:export (elisp)) (define-language elisp @@ -29,3 +30,6 @@ #:reader (lambda (port env) (read-elisp port)) #:printer write #:compilers `((tree-il . ,compile-tree-il))) + +(compile-and-load (%search-load-path "language/elisp/boot.el") + #:from 'elisp) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 4b9446250..79f4ff9e1 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -110,6 +110,7 @@ ((list? . 1) . list?) ((symbol? . 1) . symbol?) ((vector? . 1) . vector?) + ((nil? . 1) . nil?) (list . list) (vector . vector) ((class-of . 1) . class-of) @@ -527,6 +528,9 @@ ((null? ,x) (comp-push x) (emit-branch src 'br-if-not-null L1)) + ((nil? ,x) + (comp-push x) + (emit-branch src 'br-if-not-nil L1)) ((not ,x) (record-case x ((<primcall> name args) @@ -538,6 +542,9 @@ ((null? ,x) (comp-push x) (emit-branch src 'br-if-null L1)) + ((nil? ,x) + (comp-push x) + (emit-branch src 'br-if-nil L1)) (else (comp-push x) (emit-branch src 'br-if L1)))) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 3d98c686b..3c6769d51 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -46,6 +46,7 @@ ash logand logior logxor not pair? null? list? symbol? vector? string? struct? + nil? acons cons cons* list vector @@ -141,6 +142,7 @@ + * - / 1- 1+ quotient remainder modulo not pair? null? list? symbol? vector? struct? string? + nil? string-length vector-length ;; These all should get expanded out by expand-primitives!. caar cadr cdar cddr @@ -168,6 +170,7 @@ ash logand logior logxor not pair? null? list? symbol? vector? acons cons cons* + nil? list vector car cdr set-car! set-cdr! diff --git a/test-suite/tests/elisp-compiler.test b/test-suite/tests/elisp-compiler.test index 230dc772d..ddfa80a9a 100644 --- a/test-suite/tests/elisp-compiler.test +++ b/test-suite/tests/elisp-compiler.test @@ -47,6 +47,8 @@ ; Test control structures. ; ======================== +(compile '(%set-lexical-binding-mode #nil) #:from 'elisp #:to 'value) + (with-test-prefix/compile "Sequencing" (pass-if-equal "progn" 1 @@ -54,6 +56,9 @@ (setq a (1+ a)) a)) + (pass-if-equal "empty progn" #nil + (progn)) + (pass-if "prog1" (progn (setq a 0) (setq b (prog1 a (setq a (1+ a)))) @@ -77,17 +82,8 @@ 3) (equal (if nil 1) nil))) - (pass-if-equal "failing when" nil-value - (when nil 1 2 3)) - (pass-if-equal "succeeding when" 42 - (progn (setq a 0) - (when t (setq a 42) a))) - - (pass-if-equal "failing unless" nil-value - (unless t 1 2 3)) - (pass-if-equal "succeeding unless" 42 - (progn (setq a 0) - (unless nil (setq a 42) a))) + (pass-if-equal "if with no else" #nil + (if nil t)) (pass-if-equal "empty cond" nil-value (cond)) @@ -127,27 +123,7 @@ (while (<= i 5) (setq prod (* i prod)) (setq i (1+ i))) - prod)) - - (pass-if "dotimes" - (progn (setq a 0) - (setq count 100) - (setq b (dotimes (i count) - (setq j (1+ i)) - (setq a (+ a j)))) - (setq c (dotimes (i 10 42) nil)) - (and (= a 5050) (equal b nil) (= c 42)))) - - (pass-if "dolist" - (let ((mylist '(7 2 5))) - (setq sum 0) - (setq a (dolist (i mylist) - (setq sum (+ sum i)))) - (setq b (dolist (i mylist 5) 0)) - (and (= sum (+ 7 2 5)) - (equal a nil) - (equal mylist '(7 2 5)) - (equal b 5))))) + prod))) (with-test-prefix/compile "Exceptions" @@ -169,7 +145,7 @@ (= (catch 'abc (throw 'abc 2) 1) 2) (= (catch 'abc (catch 'def (throw 'abc (1+ 0)) 2) 3) 1) (= (catch 'abc (catch 'def (throw 'def 1) 2) 3) 3) - (= (catch mylist (catch '(1 2) (throw mylist 1) 2) 3) 1))) + (= (catch mylist (catch (list 1 2) (throw mylist 1) 2) 3) 1))) (pass-if "unwind-protect" (progn (setq a 0 b 1 c 1) @@ -246,6 +222,8 @@ (b a)) b))) + (pass-if-equal "empty let" #nil (let ())) + (pass-if "let*" (progn (setq a 0) (and (let* ((a 1) @@ -257,6 +235,9 @@ (= a 0) (not (boundp 'b))))) + (pass-if-equal "empty let*" #nil + (let* ())) + (pass-if "local scope" (progn (setq a 0) (setq b (let (a) @@ -303,9 +284,11 @@ (lexical-let ((a 2)) (and (= a 2) (equal (dynvals) '(1 . 1)) (let ((a 3) (b a)) + (declare (lexical a)) (and (= a 3) (= b 2) (equal (dynvals) '(1 . 2)))) (let* ((a 4) (b a)) + (declare (lexical a)) (and (= a 4) (= b 4) (equal (dynvals) '(1 . 4)))) (= a 2))) @@ -316,8 +299,11 @@ (defun dyna () a) (lexical-let ((a 2) (b 42)) (and (= a 2) (= (dyna) 1) - ((lambda (a) (and (= a 3) (= b 42) (= (dyna) 3))) 3) + ((lambda (a) + (declare (lexical a)) + (and (= a 3) (= b 42) (= (dyna) 1))) 3) ((lambda () (let ((a 3)) + (declare (lexical a)) (and (= a 3) (= (dyna) 1))))) (= a 2) (= (dyna) 1))) (= a 1))) @@ -336,34 +322,13 @@ (= (funcall c1) 4) (= (funcall c2) 3))) - (pass-if "always lexical option (all)" - (progn (setq a 0) - (defun dyna () a) - (let ((a 1)) - (and (= a 1) (= (dyna) 0)))) - #:opts '(#:always-lexical all)) - (pass-if "always lexical option (list)" - (progn (setq a 0 b 0) - (defun dyna () a) - (defun dynb () b) - (let ((a 1) - (b 1)) - (and (= a 1) (= (dyna) 0) - (= b 1) (= (dynb) 1)))) - #:opts '(#:always-lexical (a))) - (pass-if "with-always-lexical" - (progn (setq a 0) - (defun dyna () a) - (with-always-lexical (a) - (let ((a 1)) - (and (= a 1) (= (dyna) 0)))))) - (pass-if "lexical lambda args" (progn (setq a 1 b 1) (defun dyna () a) (defun dynb () b) - (with-always-lexical (a c) + (lexical-let (a c) ((lambda (a b &optional c) + (declare (lexical a c)) (and (= a 3) (= (dyna) 1) (= b 2) (= (dynb) 2) (= c 1))) @@ -373,9 +338,10 @@ ; is tail-optimized by doing a deep recursion that would otherwise overflow ; the stack. (pass-if "lexical lambda tail-recursion" - (with-always-lexical (i) + (lexical-let (i) (setq to 1000000) (defun iteration-1 (i) + (declare (lexical i)) (if (< i to) (iteration-1 (1+ i)))) (iteration-1 0) @@ -422,14 +388,17 @@ ((lambda (a b c) c) 1 2 3)) (pass-if-equal "optional argument" 3 - ((function (lambda (a &optional b c) c)) 1 2 3)) + ((lambda (a &optional b c) c) 1 2 3)) (pass-if-equal "optional missing" nil-value ((lambda (&optional a) a))) (pass-if-equal "rest argument" '(3 4 5) ((lambda (a b &rest c) c) 1 2 3 4 5)) - (pass-if-equal "rest missing" nil-value - ((lambda (a b &rest c) c) 1 2))) + (pass-if "rest missing" + (null ((lambda (a b &rest c) c) 1 2))) + + (pass-if-equal "empty lambda" #nil + ((lambda ())))) (with-test-prefix/compile "Function Definitions" @@ -453,18 +422,16 @@ (not (fboundp 'a)) (= a 1)))) - (pass-if "flet and flet*" + (pass-if "flet" (progn (defun foobar () 42) (defun test () (foobar)) (and (= (test) 42) - (flet ((foobar (lambda () 0)) - (myfoo (symbol-function 'foobar))) + (flet ((foobar () 0) + (myfoo () + (funcall (symbol-function 'foobar)))) (and (= (myfoo) 42) (= (test) 42))) - (flet* ((foobar (lambda () 0)) - (myfoo (symbol-function 'foobar))) - (= (myfoo) 42)) - (flet (foobar) + (flet ((foobar () nil)) (defun foobar () 0) (= (test) 42)) (= (test) 42))))) @@ -563,8 +530,8 @@ (setq some-string "abc") (and (eq 2 2) (not (eq 1 2)) (eq 'abc 'abc) (not (eq 'abc 'def)) - (eq some-string some-string) (not (eq some-string "abc")) - (eq some-list some-list) (not (eq some-list '(1 2))))))) + (eq some-string some-string) (not (eq some-string (string 97 98 99))) + (eq some-list some-list) (not (eq some-list (list 1 2))))))) (with-test-prefix/compile "Number Built-Ins" @@ -607,11 +574,11 @@ (with-test-prefix/compile "List Built-Ins" - (pass-if "consp and atomp" + (pass-if "consp and atom" (and (consp '(1 2 3)) (consp '(1 2 . 3)) (consp '(a . b)) (not (consp '())) (not (consp 1)) (not (consp "abc")) - (atomp 'a) (atomp '()) (atomp -1.5) (atomp "abc") - (not (atomp '(1 . 2))) (not (atomp '(1))))) + (atom 'a) (atom '()) (atom -1.5) (atom "abc") + (not (atom '(1 . 2))) (not (atom '(1))))) (pass-if "listp and nlistp" (and (listp '(1 2 3)) (listp '(1)) (listp '()) (listp '(1 . 2)) (not (listp 'a)) (not (listp 42)) (nlistp 42) @@ -628,15 +595,6 @@ (and (equal (car-safe '(1 2)) 1) (equal (cdr-safe '(1 2)) '(2)) (equal (car-safe 5) nil) (equal (cdr-safe 5) nil))) - (pass-if "pop" - (progn (setq mylist '(a b c)) - (setq value (pop mylist)) - (and (equal value 'a) - (equal mylist '(b c))))) - (pass-if-equal "push" '(a b c) - (progn (setq mylist '(b c)) - (push 'a mylist))) - (pass-if "nth and nthcdr" (and (equal (nth -5 '(1 2 3)) 1) (equal (nth 3 '(1 2 3)) nil) (equal (nth 0 '(1 2 3)) 1) (equal (nth 2 '(1 2 3)) 3) @@ -662,20 +620,6 @@ (pass-if "reverse" (and (equal (reverse '(5 4 3 2 1)) '(1 2 3 4 5)) (equal (reverse '()) '()))) - (pass-if "copy-tree" - (progn (setq mylist '(1 2 (3 4))) - (and (not (eq mylist (copy-tree mylist))) - (equal mylist (copy-tree mylist))))) - - (pass-if "number-sequence" - (and (equal (number-sequence 5) '(5)) - (equal (number-sequence 5 9) '(5 6 7 8 9)) - (equal (number-sequence 5 9 3) '(5 8)) - (equal (number-sequence 5 1 -2) '(5 3 1)) - (equal (number-sequence 5 8 -1) '()) - (equal (number-sequence 5 1) '()) - (equal (number-sequence 5 5 0) '(5)))) - (pass-if "setcar and setcdr" (progn (setq pair '(1 . 2)) (setq copy pair) |