From: Andy Wingo Date: Fri, 11 Dec 2009 09:21:31 +0000 (+0100) Subject: merge from master to elisp X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/e42573315bd70d514b92458a7644057cd3ac5757?hp=-c merge from master to elisp * module/language/elisp/compile-tree-il.scm: Update for changes to tree-il (lambda-case, mainly). * module/language/elisp/spec.scm: Update GPL version to 3. Update reader for new taking a port and environment argument. * libguile/_scm.h: Bump objcode version. * libguile/vm-i-system.c: Fix conflicts. * module/Makefile.am: Fix conflicts, and add elisp modules to the build. --- e42573315bd70d514b92458a7644057cd3ac5757 diff --combined libguile/_scm.h index 8a9a21161,810b65692..b5c818c79 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@@ -39,6 -39,9 +39,9 @@@ # include #endif + /* The size of `scm_t_bits'. */ + #define SIZEOF_SCM_T_BITS SIZEOF_VOID_P + /* Undefine HAVE_STRUCT_TIMESPEC, because the libguile C code doesn't need it anymore, and because on MinGW: @@@ -79,6 -82,7 +82,7 @@@ #include "libguile/variable.h" #include "libguile/modules.h" #include "libguile/inline.h" + #include "libguile/strings.h" #ifndef SCM_SYSCALL #ifdef vms @@@ -172,7 -176,7 +176,7 @@@ /* Major and minor versions must be single characters. */ #define SCM_OBJCODE_MAJOR_VERSION 0 - #define SCM_OBJCODE_MINOR_VERSION D -#define SCM_OBJCODE_MINOR_VERSION L ++#define SCM_OBJCODE_MINOR_VERSION M #define SCM_OBJCODE_MAJOR_VERSION_STRING \ SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION) #define SCM_OBJCODE_MINOR_VERSION_STRING \ diff --combined libguile/vm-i-system.c index 377cbf916,d7523ccb2..7de11e7d5 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@@ -46,14 -46,18 +46,18 @@@ VM_DEFINE_INSTRUCTION (1, halt, "halt" } { - ASSERT (sp == stack_base); - ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1); + #ifdef VM_ENABLE_STACK_NULLING + SCM *old_sp = sp; + #endif /* Restore registers */ sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; - ip = NULL; + /* Setting the ip here doesn't actually affect control flow, as the calling + code will restore its own registers, but it does help when walking the + stack */ + ip = SCM_FRAME_RETURN_ADDRESS (fp); fp = SCM_FRAME_DYNAMIC_LINK (fp); - NULLSTACK (stack_base - sp); + NULLSTACK (old_sp - sp); } goto vm_done; @@@ -101,37 -105,31 +105,37 @@@ VM_DEFINE_INSTRUCTION (7, make_false, " NEXT; } -VM_DEFINE_INSTRUCTION (8, make_eol, "make-eol", 0, 0, 1) +VM_DEFINE_INSTRUCTION (8, make_nil, "make-nil", 0, 0, 1) +{ + PUSH (SCM_ELISP_NIL); + NEXT; +} + +VM_DEFINE_INSTRUCTION (9, make_eol, "make-eol", 0, 0, 1) { PUSH (SCM_EOL); NEXT; } -VM_DEFINE_INSTRUCTION (9, make_int8, "make-int8", 1, 0, 1) +VM_DEFINE_INSTRUCTION (10, make_int8, "make-int8", 1, 0, 1) { PUSH (SCM_I_MAKINUM ((signed char) FETCH ())); NEXT; } -VM_DEFINE_INSTRUCTION (10, make_int8_0, "make-int8:0", 0, 0, 1) +VM_DEFINE_INSTRUCTION (11, make_int8_0, "make-int8:0", 0, 0, 1) { PUSH (SCM_INUM0); NEXT; } -VM_DEFINE_INSTRUCTION (11, make_int8_1, "make-int8:1", 0, 0, 1) +VM_DEFINE_INSTRUCTION (12, make_int8_1, "make-int8:1", 0, 0, 1) { PUSH (SCM_I_MAKINUM (1)); NEXT; } -VM_DEFINE_INSTRUCTION (12, make_int16, "make-int16", 2, 0, 1) +VM_DEFINE_INSTRUCTION (13, make_int16, "make-int16", 2, 0, 1) { int h = FETCH (); int l = FETCH (); @@@ -139,7 -137,7 +143,7 @@@ NEXT; } -VM_DEFINE_INSTRUCTION (13, make_int64, "make-int64", 8, 0, 1) +VM_DEFINE_INSTRUCTION (14, make_int64, "make-int64", 8, 0, 1) { scm_t_uint64 v = 0; v += FETCH (); @@@ -154,7 -152,7 +158,7 @@@ NEXT; } -VM_DEFINE_INSTRUCTION (14, make_uint64, "make-uint64", 8, 0, 1) +VM_DEFINE_INSTRUCTION (15, make_uint64, "make-uint64", 8, 0, 1) { scm_t_uint64 v = 0; v += FETCH (); @@@ -169,7 -167,7 +173,7 @@@ NEXT; } -VM_DEFINE_INSTRUCTION (15, make_char8, "make-char8", 1, 0, 1) +VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0, 1) { scm_t_uint8 v = 0; v = FETCH (); @@@ -181,7 -179,7 +185,7 @@@ NEXT; } -VM_DEFINE_INSTRUCTION (16, make_char32, "make-char32", 4, 0, 1) +VM_DEFINE_INSTRUCTION (17, make_char32, "make-char32", 4, 0, 1) { scm_t_wchar v = 0; v += FETCH (); @@@ -194,7 -192,7 +198,7 @@@ -VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1) +VM_DEFINE_INSTRUCTION (18, list, "list", 2, -1, 1) { unsigned h = FETCH (); unsigned l = FETCH (); @@@ -203,7 -201,7 +207,7 @@@ NEXT; } -VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1) +VM_DEFINE_INSTRUCTION (19, vector, "vector", 2, -1, 1) { unsigned h = FETCH (); unsigned l = FETCH (); @@@ -243,7 -241,7 +247,7 @@@ /* ref */ -VM_DEFINE_INSTRUCTION (19, object_ref, "object-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (20, object_ref, "object-ref", 1, 0, 1) { register unsigned objnum = FETCH (); CHECK_OBJECT (objnum); @@@ -252,7 -250,7 +256,7 @@@ } /* FIXME: necessary? elt 255 of the vector could be a vector... */ -VM_DEFINE_INSTRUCTION (20, long_object_ref, "long-object-ref", 2, 0, 1) +VM_DEFINE_INSTRUCTION (21, long_object_ref, "long-object-ref", 2, 0, 1) { unsigned int objnum = FETCH (); objnum <<= 8; @@@ -262,14 -260,14 +266,14 @@@ NEXT; } -VM_DEFINE_INSTRUCTION (21, local_ref, "local-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1) { PUSH (LOCAL_REF (FETCH ())); ASSERT_BOUND (*sp); NEXT; } -VM_DEFINE_INSTRUCTION (22, long_local_ref, "long-local-ref", 2, 0, 1) +VM_DEFINE_INSTRUCTION (23, long_local_ref, "long-local-ref", 2, 0, 1) { unsigned int i = FETCH (); i <<= 8; @@@ -279,7 -277,28 +283,28 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (24, variable_ref, "variable-ref", 0, 0, 1) -VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1) ++VM_DEFINE_INSTRUCTION (24, local_bound, "local-bound?", 1, 0, 1) + { + if (LOCAL_REF (FETCH ()) == SCM_UNDEFINED) + PUSH (SCM_BOOL_F); + else + PUSH (SCM_BOOL_T); + NEXT; + } + -VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1) ++VM_DEFINE_INSTRUCTION (25, long_local_bound, "long-local-bound?", 2, 0, 1) + { + unsigned int i = FETCH (); + i <<= 8; + i += FETCH (); + if (LOCAL_REF (i) == SCM_UNDEFINED) + PUSH (SCM_BOOL_F); + else + PUSH (SCM_BOOL_T); + NEXT; + } + -VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 0, 1, 1) ++VM_DEFINE_INSTRUCTION (26, variable_ref, "variable-ref", 0, 1, 1) { SCM x = *sp; @@@ -298,7 -317,16 +323,16 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1) -VM_DEFINE_INSTRUCTION (26, variable_bound, "variable-bound?", 0, 0, 1) ++VM_DEFINE_INSTRUCTION (27, variable_bound, "variable-bound?", 0, 0, 1) + { + if (VARIABLE_BOUNDP (*sp)) + *sp = SCM_BOOL_T; + else + *sp = SCM_BOOL_F; + NEXT; + } + -VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1, 0, 1) ++VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1, 0, 1) { unsigned objnum = FETCH (); SCM what; @@@ -321,7 -349,7 +355,7 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (26, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1) -VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1) ++VM_DEFINE_INSTRUCTION (29, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1) { SCM what; unsigned int objnum = FETCH (); @@@ -348,14 -376,14 +382,14 @@@ /* set */ - VM_DEFINE_INSTRUCTION (27, local_set, "local-set", 1, 1, 0) -VM_DEFINE_INSTRUCTION (29, local_set, "local-set", 1, 1, 0) ++VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0) { LOCAL_SET (FETCH (), *sp); DROP (); NEXT; } - VM_DEFINE_INSTRUCTION (28, long_local_set, "long-local-set", 2, 1, 0) -VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0) ++VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0) { unsigned int i = FETCH (); i <<= 8; @@@ -365,14 -393,14 +399,14 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (29, variable_set, "variable-set", 0, 1, 0) -VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 2, 0) ++VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 2, 0) { VARIABLE_SET (sp[0], sp[-1]); DROPN (2); NEXT; } - VM_DEFINE_INSTRUCTION (30, toplevel_set, "toplevel-set", 1, 1, 0) -VM_DEFINE_INSTRUCTION (32, toplevel_set, "toplevel-set", 1, 1, 0) ++VM_DEFINE_INSTRUCTION (33, toplevel_set, "toplevel-set", 1, 1, 0) { unsigned objnum = FETCH (); SCM what; @@@ -391,7 -419,7 +425,7 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (31, long_toplevel_set, "long-toplevel-set", 2, 1, 0) -VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0) ++VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0) { SCM what; unsigned int objnum = FETCH (); @@@ -417,63 -445,64 +451,64 @@@ * branch and jump */ - /* offset must be a signed 16 bit int!!! */ + /* offset must be at least 24 bits wide, and signed */ #define FETCH_OFFSET(offset) \ { \ - int h = FETCH (); \ - int l = FETCH (); \ - offset = (h << 8) + l; \ + offset = FETCH () << 16; \ + offset += FETCH () << 8; \ + offset += FETCH (); \ + offset -= (offset & (1<<23)) << 1; \ } #define BR(p) \ { \ - scm_t_int16 offset; \ + scm_t_int32 offset; \ FETCH_OFFSET (offset); \ if (p) \ - ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8); \ + ip += offset; \ NULLSTACK (1); \ DROP (); \ NEXT; \ } - VM_DEFINE_INSTRUCTION (32, br, "br", 2, 0, 0) -VM_DEFINE_INSTRUCTION (34, br, "br", 3, 0, 0) ++VM_DEFINE_INSTRUCTION (35, br, "br", 3, 0, 0) { - scm_t_int16 offset; + scm_t_int32 offset; FETCH_OFFSET (offset); - ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8); + ip += offset; NEXT; } - VM_DEFINE_INSTRUCTION (33, br_if, "br-if", 2, 0, 0) -VM_DEFINE_INSTRUCTION (35, br_if, "br-if", 3, 0, 0) ++VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 3, 0, 0) { - BR (!SCM_FALSEP (*sp)); + BR (scm_is_true_and_not_nil (*sp)); } - VM_DEFINE_INSTRUCTION (34, br_if_not, "br-if-not", 2, 0, 0) -VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0) ++VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 3, 0, 0) { - BR (SCM_FALSEP (*sp)); + BR (scm_is_false_or_nil (*sp)); } - VM_DEFINE_INSTRUCTION (35, br_if_eq, "br-if-eq", 2, 0, 0) -VM_DEFINE_INSTRUCTION (37, br_if_eq, "br-if-eq", 3, 0, 0) ++VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 3, 0, 0) { sp--; /* underflow? */ - BR (SCM_EQ_P (sp[0], sp[1])); + BR (scm_is_eq (sp[0], sp[1])); } - VM_DEFINE_INSTRUCTION (36, br_if_not_eq, "br-if-not-eq", 2, 0, 0) -VM_DEFINE_INSTRUCTION (38, br_if_not_eq, "br-if-not-eq", 3, 0, 0) ++VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq", 3, 0, 0) { sp--; /* underflow? */ - BR (!SCM_EQ_P (sp[0], sp[1])); + BR (!scm_is_eq (sp[0], sp[1])); } - VM_DEFINE_INSTRUCTION (37, br_if_null, "br-if-null", 2, 0, 0) -VM_DEFINE_INSTRUCTION (39, br_if_null, "br-if-null", 3, 0, 0) ++VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 3, 0, 0) { - BR (SCM_NULLP (*sp)); + BR (scm_is_null_or_nil (*sp)); } - VM_DEFINE_INSTRUCTION (38, br_if_not_null, "br-if-not-null", 2, 0, 0) -VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0) ++VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 3, 0, 0) { - BR (!SCM_NULLP (*sp)); + BR (!scm_is_null_or_nil (*sp)); } @@@ -481,15 -510,230 +516,230 @@@ * Subprogram call */ - VM_DEFINE_INSTRUCTION (39, new_frame, "new-frame", 0, 0, 3) -VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0) ++VM_DEFINE_INSTRUCTION (42, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0) + { + scm_t_ptrdiff n; + scm_t_int32 offset; + n = FETCH () << 8; + n += FETCH (); + FETCH_OFFSET (offset); + if (sp - (fp - 1) != n) + ip += offset; + NEXT; + } + -VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0) ++VM_DEFINE_INSTRUCTION (43, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0) + { + scm_t_ptrdiff n; + scm_t_int32 offset; + n = FETCH () << 8; + n += FETCH (); + FETCH_OFFSET (offset); + if (sp - (fp - 1) < n) + ip += offset; + NEXT; + } + -VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0) ++VM_DEFINE_INSTRUCTION (44, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0) + { + scm_t_ptrdiff n; + scm_t_int32 offset; + + n = FETCH () << 8; + n += FETCH (); + FETCH_OFFSET (offset); + if (sp - (fp - 1) > n) + ip += offset; + NEXT; + } + -VM_DEFINE_INSTRUCTION (44, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0) ++VM_DEFINE_INSTRUCTION (45, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0) + { + scm_t_ptrdiff n; + n = FETCH () << 8; + n += FETCH (); + if (sp - (fp - 1) != n) + goto vm_error_wrong_num_args; + NEXT; + } + -VM_DEFINE_INSTRUCTION (45, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0) ++VM_DEFINE_INSTRUCTION (46, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0) + { + scm_t_ptrdiff n; + n = FETCH () << 8; + n += FETCH (); + if (sp - (fp - 1) < n) + goto vm_error_wrong_num_args; + NEXT; + } + -VM_DEFINE_INSTRUCTION (46, bind_optionals, "bind-optionals", 2, -1, -1) ++VM_DEFINE_INSTRUCTION (47, bind_optionals, "bind-optionals", 2, -1, -1) + { + scm_t_ptrdiff n; + n = FETCH () << 8; + n += FETCH (); + while (sp - (fp - 1) < n) + PUSH (SCM_UNDEFINED); + NEXT; + } + -VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1) ++VM_DEFINE_INSTRUCTION (48, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1) + { + SCM *walk; + scm_t_ptrdiff nreq, nreq_and_opt, ntotal; + nreq = FETCH () << 8; + nreq += FETCH (); + nreq_and_opt = FETCH () << 8; + nreq_and_opt += FETCH (); + ntotal = FETCH () << 8; + ntotal += FETCH (); + + /* look in optionals for first keyword or last positional */ + /* starting after the last required positional arg */ + walk = fp + nreq; + while (/* while we have args */ + walk <= sp + /* and we still have positionals to fill */ + && walk - fp < nreq_and_opt + /* and we haven't reached a keyword yet */ + && !scm_is_keyword (*walk)) + /* bind this optional arg (by leaving it in place) */ + walk++; + /* now shuffle up, from walk to ntotal */ + { + scm_t_ptrdiff nshuf = sp - walk + 1, i; + sp = (fp - 1) + ntotal + nshuf; + CHECK_OVERFLOW (); + for (i = 0; i < nshuf; i++) + sp[-i] = walk[nshuf-i-1]; + } + /* and fill optionals & keyword args with SCM_UNDEFINED */ + while (walk <= (fp - 1) + ntotal) + *walk++ = SCM_UNDEFINED; + + NEXT; + } + + /* Flags that determine whether other keywords are allowed, and whether a + rest argument is expected. These values must match those used by the + glil->assembly compiler. */ + #define F_ALLOW_OTHER_KEYS 1 + #define F_REST 2 + -VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0) ++VM_DEFINE_INSTRUCTION (49, bind_kwargs, "bind-kwargs", 5, 0, 0) + { + scm_t_uint16 idx; + scm_t_ptrdiff nkw; + int kw_and_rest_flags; + SCM kw; + idx = FETCH () << 8; + idx += FETCH (); + /* XXX: We don't actually use NKW. */ + nkw = FETCH () << 8; + nkw += FETCH (); + kw_and_rest_flags = FETCH (); + + if (!(kw_and_rest_flags & F_REST) + && ((sp - (fp - 1) - nkw) % 2)) + goto vm_error_kwargs_length_not_even; + + CHECK_OBJECT (idx); + kw = OBJECT_REF (idx); + + /* Switch NKW to be a negative index below SP. */ + for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw++) + { + SCM walk; + + if (scm_is_keyword (sp[nkw])) + { + for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk)) + { + if (scm_is_eq (SCM_CAAR (walk), sp[nkw])) + { + SCM si = SCM_CDAR (walk); + LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si), + sp[nkw + 1]); + break; + } + } + if (!(kw_and_rest_flags & F_ALLOW_OTHER_KEYS) && !scm_is_pair (walk)) + goto vm_error_kwargs_unrecognized_keyword; + + nkw++; + } + else if (!(kw_and_rest_flags & F_REST)) + goto vm_error_kwargs_invalid_keyword; + } + + NEXT; + } + + #undef F_ALLOW_OTHER_KEYS + #undef F_REST + + -VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1) ++VM_DEFINE_INSTRUCTION (50, push_rest, "push-rest", 2, -1, -1) + { + scm_t_ptrdiff n; + SCM rest = SCM_EOL; + n = FETCH () << 8; + n += FETCH (); + while (sp - (fp - 1) > n) + /* No need to check for underflow. */ + CONS (rest, *sp--, rest); + PUSH (rest); + NEXT; + } + -VM_DEFINE_INSTRUCTION (50, bind_rest, "bind-rest", 4, -1, -1) ++VM_DEFINE_INSTRUCTION (51, bind_rest, "bind-rest", 4, -1, -1) + { + scm_t_ptrdiff n; + scm_t_uint32 i; + SCM rest = SCM_EOL; + n = FETCH () << 8; + n += FETCH (); + i = FETCH () << 8; + i += FETCH (); + while (sp - (fp - 1) > n) + /* No need to check for underflow. */ + CONS (rest, *sp--, rest); + LOCAL_SET (i, rest); + NEXT; + } + -VM_DEFINE_INSTRUCTION (51, reserve_locals, "reserve-locals", 2, -1, -1) ++VM_DEFINE_INSTRUCTION (52, reserve_locals, "reserve-locals", 2, -1, -1) { + SCM *old_sp; + scm_t_int32 n; + n = FETCH () << 8; + n += FETCH (); + old_sp = sp; + sp = (fp - 1) + n; + + if (old_sp < sp) + { + CHECK_OVERFLOW (); + while (old_sp < sp) + *++old_sp = SCM_UNDEFINED; + } + else + NULLSTACK (old_sp - sp); + + NEXT; + } + -VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3) ++VM_DEFINE_INSTRUCTION (53, new_frame, "new-frame", 0, 0, 3) + { + /* NB: if you change this, see frames.c:vm-frame-num-locals */ + /* and frames.h, vm-engine.c, etc of course */ PUSH ((SCM)fp); /* dynamic link */ PUSH (0); /* mvra */ PUSH (0); /* ra */ NEXT; } - VM_DEFINE_INSTRUCTION (40, call, "call", 1, -1, 1) -VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1) ++VM_DEFINE_INSTRUCTION (54, call, "call", 1, -1, 1) { SCM x; nargs = FETCH (); @@@ -507,43 -751,48 +757,48 @@@ { program = x; CACHE_PROGRAM (); - INIT_ARGS (); - fp = sp - bp->nargs + 1; + fp = sp - nargs + 1; ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0); - INIT_FRAME (); + ip = bp->base; ENTER_HOOK (); APPLY_HOOK (); NEXT; } + if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x)) + { + sp[-nargs] = SCM_STRUCT_PROCEDURE (x); + goto vm_call; + } /* * Other interpreted or compiled call */ - if (!SCM_FALSEP (scm_procedure_p (x))) + if (!scm_is_false (scm_procedure_p (x))) { - SCM args; + SCM ret; /* At this point, the stack contains the frame, the procedure and each one of its arguments. */ - POP_LIST (nargs); - POP (args); - DROP (); /* drop the procedure */ - DROP_FRAME (); - SYNC_REGISTER (); - PUSH (scm_apply (x, args, SCM_EOL)); + ret = apply_foreign (sp[-nargs], + sp - nargs + 1, + nargs, + vp->stack_limit - sp + 1); NULLSTACK_FOR_NONLOCAL_EXIT (); - if (SCM_UNLIKELY (SCM_VALUESP (*sp))) + DROPN (nargs + 1); /* drop args and procedure */ + DROP_FRAME (); + + if (SCM_UNLIKELY (SCM_VALUESP (ret))) { /* truncate values */ - SCM values; - POP (values); - values = scm_struct_ref (values, SCM_INUM0); - if (scm_is_null (values)) + ret = scm_struct_ref (ret, SCM_INUM0); + if (scm_is_null (ret)) goto vm_error_not_enough_values; - PUSH (SCM_CAR (values)); + PUSH (SCM_CAR (ret)); } + else + PUSH (ret); NEXT; } @@@ -551,7 -800,7 +806,7 @@@ goto vm_error_wrong_type_apply; } - VM_DEFINE_INSTRUCTION (41, goto_args, "goto/args", 1, -1, 1) -VM_DEFINE_INSTRUCTION (54, goto_args, "goto/args", 1, -1, 1) ++VM_DEFINE_INSTRUCTION (55, goto_args, "goto/args", 1, -1, 1) { register SCM x; nargs = FETCH (); @@@ -568,7 -817,8 +823,8 @@@ { int i; #ifdef VM_ENABLE_STACK_NULLING - SCM *old_sp; + SCM *old_sp = sp; + CHECK_STACK_LEAK (); #endif EXIT_HOOK (); @@@ -576,53 -826,52 +832,52 @@@ /* switch programs */ program = x; CACHE_PROGRAM (); - INIT_ARGS (); - - #ifdef VM_ENABLE_STACK_NULLING - old_sp = sp; - CHECK_STACK_LEAK (); - #endif + /* shuffle down the program and the arguments */ + for (i = -1, sp = sp - nargs + 1; i < nargs; i++) + SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i]; - /* delay shuffling the new program+args down so that if INIT_ARGS had to - cons up a rest arg, going into GC, the stack still made sense */ - for (i = -1, sp = sp - bp->nargs + 1; i < bp->nargs; i++) - fp[i] = sp[i]; sp = fp + i - 1; NULLSTACK (old_sp - sp); - INIT_FRAME (); + ip = bp->base; ENTER_HOOK (); APPLY_HOOK (); NEXT; } - + if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x)) + { + sp[-nargs] = SCM_STRUCT_PROCEDURE (x); + goto vm_goto_args; + } /* * Other interpreted or compiled call */ - if (!SCM_FALSEP (scm_procedure_p (x))) + if (!scm_is_false (scm_procedure_p (x))) { - SCM args; - POP_LIST (nargs); - POP (args); - + SCM ret; SYNC_REGISTER (); - *sp = scm_apply (x, args, SCM_EOL); + ret = apply_foreign (sp[-nargs], + sp - nargs + 1, + nargs, + vp->stack_limit - sp + 1); NULLSTACK_FOR_NONLOCAL_EXIT (); - - if (SCM_UNLIKELY (SCM_VALUESP (*sp))) + DROPN (nargs + 1); /* drop args and procedure */ + + if (SCM_UNLIKELY (SCM_VALUESP (ret))) { /* multiple values returned to continuation */ - SCM values; - POP (values); - values = scm_struct_ref (values, SCM_INUM0); - nvalues = scm_ilength (values); - PUSH_LIST (values, SCM_NULLP); + ret = scm_struct_ref (ret, SCM_INUM0); + nvalues = scm_ilength (ret); + PUSH_LIST (ret, scm_is_null); goto vm_return_values; } else - goto vm_return; + { + PUSH (ret); + goto vm_return; + } } program = x; @@@ -630,7 -879,7 +885,7 @@@ goto vm_error_wrong_type_apply; } - VM_DEFINE_INSTRUCTION (42, goto_nargs, "goto/nargs", 0, 0, 1) -VM_DEFINE_INSTRUCTION (55, goto_nargs, "goto/nargs", 0, 0, 1) ++VM_DEFINE_INSTRUCTION (56, goto_nargs, "goto/nargs", 0, 0, 1) { SCM x; POP (x); @@@ -639,7 -888,7 +894,7 @@@ goto vm_goto_args; } - VM_DEFINE_INSTRUCTION (43, call_nargs, "call/nargs", 0, 0, 1) -VM_DEFINE_INSTRUCTION (56, call_nargs, "call/nargs", 0, 0, 1) ++VM_DEFINE_INSTRUCTION (57, call_nargs, "call/nargs", 0, 0, 1) { SCM x; POP (x); @@@ -648,16 -897,17 +903,17 @@@ goto vm_call; } - VM_DEFINE_INSTRUCTION (44, mv_call, "mv-call", 3, -1, 1) -VM_DEFINE_INSTRUCTION (57, mv_call, "mv-call", 4, -1, 1) ++VM_DEFINE_INSTRUCTION (58, mv_call, "mv-call", 4, -1, 1) { SCM x; - scm_t_int16 offset; + scm_t_int32 offset; scm_t_uint8 *mvra; nargs = FETCH (); FETCH_OFFSET (offset); - mvra = ip + ((scm_t_ptrdiff)offset) * 8 - ((unsigned long)ip) % 8; + mvra = ip + offset; + vm_mv_call: x = sp[-nargs]; /* @@@ -667,43 -917,49 +923,49 @@@ { program = x; CACHE_PROGRAM (); - INIT_ARGS (); - fp = sp - bp->nargs + 1; + fp = sp - nargs + 1; ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra); - INIT_FRAME (); + ip = bp->base; ENTER_HOOK (); APPLY_HOOK (); NEXT; } + if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x)) + { + sp[-nargs] = SCM_STRUCT_PROCEDURE (x); + goto vm_mv_call; + } /* * Other interpreted or compiled call */ - if (!SCM_FALSEP (scm_procedure_p (x))) + if (!scm_is_false (scm_procedure_p (x))) { - SCM args; - /* At this point, the stack contains the procedure and each one of its - arguments. */ - POP_LIST (nargs); - POP (args); - DROP (); /* drop the procedure */ - DROP_FRAME (); - + SCM ret; + /* At this point, the stack contains the frame, the procedure and each one + of its arguments. */ SYNC_REGISTER (); - PUSH (scm_apply (x, args, SCM_EOL)); + ret = apply_foreign (sp[-nargs], + sp - nargs + 1, + nargs, + vp->stack_limit - sp + 1); NULLSTACK_FOR_NONLOCAL_EXIT (); - if (SCM_VALUESP (*sp)) + DROPN (nargs + 1); /* drop args and procedure */ + DROP_FRAME (); + + if (SCM_VALUESP (ret)) { - SCM values, len; - POP (values); - values = scm_struct_ref (values, SCM_INUM0); - len = scm_length (values); - PUSH_LIST (values, SCM_NULLP); + SCM len; + ret = scm_struct_ref (ret, SCM_INUM0); + len = scm_length (ret); + PUSH_LIST (ret, scm_is_null); PUSH (len); ip = mvra; } + else + PUSH (ret); NEXT; } @@@ -711,7 -967,7 +973,7 @@@ goto vm_error_wrong_type_apply; } - VM_DEFINE_INSTRUCTION (45, apply, "apply", 1, -1, 1) -VM_DEFINE_INSTRUCTION (58, apply, "apply", 1, -1, 1) ++VM_DEFINE_INSTRUCTION (59, apply, "apply", 1, -1, 1) { int len; SCM ls; @@@ -730,7 -986,7 +992,7 @@@ goto vm_call; } - VM_DEFINE_INSTRUCTION (46, goto_apply, "goto/apply", 1, -1, 1) -VM_DEFINE_INSTRUCTION (59, goto_apply, "goto/apply", 1, -1, 1) ++VM_DEFINE_INSTRUCTION (60, goto_apply, "goto/apply", 1, -1, 1) { int len; SCM ls; @@@ -749,7 -1005,7 +1011,7 @@@ goto vm_goto_args; } - VM_DEFINE_INSTRUCTION (47, call_cc, "call/cc", 0, 1, 1) -VM_DEFINE_INSTRUCTION (60, call_cc, "call/cc", 0, 1, 1) ++VM_DEFINE_INSTRUCTION (61, call_cc, "call/cc", 0, 1, 1) { int first; SCM proc, cont; @@@ -773,7 -1029,7 +1035,7 @@@ /* multiple values returned to continuation */ SCM values; values = scm_struct_ref (cont, SCM_INUM0); - if (SCM_NULLP (values)) + if (scm_is_null (values)) goto vm_error_no_values; /* non-tail context does not accept multiple values? */ PUSH (SCM_CAR (values)); @@@ -786,7 -1042,7 +1048,7 @@@ } } - VM_DEFINE_INSTRUCTION (48, goto_cc, "goto/cc", 0, 1, 1) -VM_DEFINE_INSTRUCTION (61, goto_cc, "goto/cc", 0, 1, 1) ++VM_DEFINE_INSTRUCTION (62, goto_cc, "goto/cc", 0, 1, 1) { int first; SCM proc, cont; @@@ -808,7 -1064,7 +1070,7 @@@ SCM values; values = scm_struct_ref (cont, SCM_INUM0); nvalues = scm_ilength (values); - PUSH_LIST (values, SCM_NULLP); + PUSH_LIST (values, scm_is_null); goto vm_return_values; } else @@@ -818,7 -1074,7 +1080,7 @@@ } } - VM_DEFINE_INSTRUCTION (49, return, "return", 0, 1, 1) -VM_DEFINE_INSTRUCTION (62, return, "return", 0, 1, 1) ++VM_DEFINE_INSTRUCTION (63, return, "return", 0, 1, 1) { vm_return: EXIT_HOOK (); @@@ -829,20 -1085,19 +1091,19 @@@ SCM ret; POP (ret); - ASSERT (sp == stack_base); - ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1); + + #ifdef VM_ENABLE_STACK_NULLING + SCM *old_sp = sp; + #endif /* Restore registers */ sp = SCM_FRAME_LOWER_ADDRESS (fp); ip = SCM_FRAME_RETURN_ADDRESS (fp); fp = SCM_FRAME_DYNAMIC_LINK (fp); - { + #ifdef VM_ENABLE_STACK_NULLING - int nullcount = stack_base - sp; + NULLSTACK (old_sp - sp); #endif - stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1; - NULLSTACK (nullcount); - } /* Set return value (sp is already pushed) */ *sp = ret; @@@ -855,7 -1110,7 +1116,7 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (50, return_values, "return/values", 1, -1, -1) -VM_DEFINE_INSTRUCTION (63, return_values, "return/values", 1, -1, -1) ++VM_DEFINE_INSTRUCTION (64, return_values, "return/values", 1, -1, -1) { /* nvalues declared at top level, because for some reason gcc seems to think that perhaps it might be used without declaration. Fooey to that, I say. */ @@@ -864,11 -1119,10 +1125,10 @@@ EXIT_HOOK (); RETURN_HOOK (); - ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1); - - /* data[1] is the mv return address */ if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp)) { + /* A multiply-valued continuation */ + SCM *vals = sp - nvalues; int i; /* Restore registers */ sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; @@@ -877,12 -1131,11 +1137,11 @@@ /* Push return values, and the number of values */ for (i = 0; i < nvalues; i++) - *++sp = stack_base[1+i]; + *++sp = vals[i+1]; *++sp = SCM_I_MAKINUM (nvalues); - /* Finally set new stack_base */ - NULLSTACK (stack_base - sp + nvalues + 1); - stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1; + /* Finally null the end of the stack */ + NULLSTACK (vals + nvalues - sp); } else if (nvalues >= 1) { @@@ -890,17 -1143,17 +1149,17 @@@ break with guile tradition and try and do something sensible. (Also, this block handles the single-valued return to an mv continuation.) */ + SCM *vals = sp - nvalues; /* Restore registers */ sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; ip = SCM_FRAME_RETURN_ADDRESS (fp); fp = SCM_FRAME_DYNAMIC_LINK (fp); /* Push first value */ - *++sp = stack_base[1]; + *++sp = vals[1]; - /* Finally set new stack_base */ - NULLSTACK (stack_base - sp + nvalues + 1); - stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1; + /* Finally null the end of the stack */ + NULLSTACK (vals + nvalues - sp); } else goto vm_error_no_values; @@@ -912,7 -1165,7 +1171,7 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (51, return_values_star, "return/values*", 1, -1, -1) -VM_DEFINE_INSTRUCTION (64, return_values_star, "return/values*", 1, -1, -1) ++VM_DEFINE_INSTRUCTION (65, return_values_star, "return/values*", 1, -1, -1) { SCM l; @@@ -921,7 -1174,7 +1180,7 @@@ nvalues--; POP (l); - while (SCM_CONSP (l)) + while (scm_is_pair (l)) { PUSH (SCM_CAR (l)); l = SCM_CDR (l); @@@ -935,7 -1188,7 +1194,7 @@@ goto vm_return_values; } - VM_DEFINE_INSTRUCTION (52, truncate_values, "truncate-values", 2, -1, -1) -VM_DEFINE_INSTRUCTION (65, truncate_values, "truncate-values", 2, -1, -1) ++VM_DEFINE_INSTRUCTION (66, truncate_values, "truncate-values", 2, -1, -1) { SCM x; int nbinds, rest; @@@ -958,7 -1211,7 +1217,7 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (53, box, "box", 1, 1, 0) -VM_DEFINE_INSTRUCTION (66, box, "box", 1, 1, 0) ++VM_DEFINE_INSTRUCTION (67, box, "box", 1, 1, 0) { SCM val; POP (val); @@@ -972,7 -1225,7 +1231,7 @@@ (set! a (lambda () (b ...))) ...) */ - VM_DEFINE_INSTRUCTION (54, empty_box, "empty-box", 1, 0, 0) -VM_DEFINE_INSTRUCTION (67, empty_box, "empty-box", 1, 0, 0) ++VM_DEFINE_INSTRUCTION (68, empty_box, "empty-box", 1, 0, 0) { SYNC_BEFORE_GC (); LOCAL_SET (FETCH (), @@@ -980,7 -1233,7 +1239,7 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (55, local_boxed_ref, "local-boxed-ref", 1, 0, 1) -VM_DEFINE_INSTRUCTION (68, local_boxed_ref, "local-boxed-ref", 1, 0, 1) ++VM_DEFINE_INSTRUCTION (69, local_boxed_ref, "local-boxed-ref", 1, 0, 1) { SCM v = LOCAL_REF (FETCH ()); ASSERT_BOUND_VARIABLE (v); @@@ -988,7 -1241,7 +1247,7 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (56, local_boxed_set, "local-boxed-set", 1, 1, 0) -VM_DEFINE_INSTRUCTION (69, local_boxed_set, "local-boxed-set", 1, 1, 0) ++VM_DEFINE_INSTRUCTION (70, local_boxed_set, "local-boxed-set", 1, 1, 0) { SCM v, val; v = LOCAL_REF (FETCH ()); @@@ -998,7 -1251,7 +1257,7 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (57, free_ref, "free-ref", 1, 0, 1) -VM_DEFINE_INSTRUCTION (70, free_ref, "free-ref", 1, 0, 1) ++VM_DEFINE_INSTRUCTION (71, free_ref, "free-ref", 1, 0, 1) { scm_t_uint8 idx = FETCH (); @@@ -1009,7 -1262,7 +1268,7 @@@ /* no free-set -- if a var is assigned, it should be in a box */ - VM_DEFINE_INSTRUCTION (58, free_boxed_ref, "free-boxed-ref", 1, 0, 1) -VM_DEFINE_INSTRUCTION (71, free_boxed_ref, "free-boxed-ref", 1, 0, 1) ++VM_DEFINE_INSTRUCTION (72, free_boxed_ref, "free-boxed-ref", 1, 0, 1) { SCM v; scm_t_uint8 idx = FETCH (); @@@ -1020,7 -1273,7 +1279,7 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (59, free_boxed_set, "free-boxed-set", 1, 1, 0) -VM_DEFINE_INSTRUCTION (72, free_boxed_set, "free-boxed-set", 1, 1, 0) ++VM_DEFINE_INSTRUCTION (73, free_boxed_set, "free-boxed-set", 1, 1, 0) { SCM v, val; scm_t_uint8 idx = FETCH (); @@@ -1032,7 -1285,7 +1291,7 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (60, make_closure, "make-closure", 0, 2, 1) -VM_DEFINE_INSTRUCTION (73, make_closure, "make-closure", 0, 2, 1) ++VM_DEFINE_INSTRUCTION (74, make_closure, "make-closure", 0, 2, 1) { SCM vect; POP (vect); @@@ -1043,7 -1296,7 +1302,7 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (61, make_variable, "make-variable", 0, 0, 1) -VM_DEFINE_INSTRUCTION (74, make_variable, "make-variable", 0, 0, 1) ++VM_DEFINE_INSTRUCTION (75, make_variable, "make-variable", 0, 0, 1) { SYNC_BEFORE_GC (); /* fixme underflow */ @@@ -1051,7 -1304,7 +1310,7 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (62, fix_closure, "fix-closure", 2, 0, 1) -VM_DEFINE_INSTRUCTION (75, fix_closure, "fix-closure", 2, 0, 1) ++VM_DEFINE_INSTRUCTION (76, fix_closure, "fix-closure", 2, 0, 1) { SCM x, vect; unsigned int i = FETCH (); @@@ -1065,7 -1318,7 +1324,7 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (63, define, "define", 0, 0, 2) -VM_DEFINE_INSTRUCTION (76, define, "define", 0, 0, 2) ++VM_DEFINE_INSTRUCTION (77, define, "define", 0, 0, 2) { SCM sym, val; POP (sym); @@@ -1077,7 -1330,7 +1336,7 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (64, make_keyword, "make-keyword", 0, 1, 1) -VM_DEFINE_INSTRUCTION (77, make_keyword, "make-keyword", 0, 1, 1) ++VM_DEFINE_INSTRUCTION (78, make_keyword, "make-keyword", 0, 1, 1) { CHECK_UNDERFLOW (); SYNC_REGISTER (); @@@ -1085,7 -1338,7 +1344,7 @@@ NEXT; } - VM_DEFINE_INSTRUCTION (65, make_symbol, "make-symbol", 0, 1, 1) -VM_DEFINE_INSTRUCTION (78, make_symbol, "make-symbol", 0, 1, 1) ++VM_DEFINE_INSTRUCTION (79, make_symbol, "make-symbol", 0, 1, 1) { CHECK_UNDERFLOW (); SYNC_REGISTER (); @@@ -1104,7 -1357,6 +1363,7 @@@ (replace-match (number-to-string (setq counter (1+ counter))) t t nil 1))))) +(renumber-ops) */ /* Local Variables: diff --combined module/Makefile.am index d1c2d95ce,90e05347f..21c36243a --- a/module/Makefile.am +++ b/module/Makefile.am @@@ -24,39 -24,52 +24,53 @@@ include $(top_srcdir)/am/guile # We're at the root of the module hierarchy. modpath = - # Compile psyntax and boot-9 first, so that we get the speed benefit in - # the rest of the compilation. Also, if there is too much switching back - # and forth between interpreted and compiled code, we end up using more - # of the C stack than the interpreter would have; so avoid that by - # putting these core modules first. + BEGINNING_OF_TIME=198001010100 - SOURCES = \ - ice-9/psyntax-pp.scm \ - system/base/pmatch.scm system/base/syntax.scm \ - system/base/compile.scm system/base/language.scm \ - system/base/message.scm \ - \ - language/tree-il.scm \ - language/glil.scm language/assembly.scm \ - \ - $(SCHEME_LANG_SOURCES) \ - $(TREE_IL_LANG_SOURCES) \ - $(GLIL_LANG_SOURCES) \ - $(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \ - $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \ - \ - $(ICE_9_SOURCES) \ - $(SRFI_SOURCES) \ - $(RNRS_SOURCES) \ - $(OOP_SOURCES) \ - $(SYSTEM_SOURCES) \ - $(SCRIPTS_SOURCES) \ - $(GHIL_LANG_SOURCES) \ - $(ECMASCRIPT_LANG_SOURCES) \ + $(GOBJECTS): ice-9/eval.go.stamp + ice-9/eval.go.stamp: ice-9/eval.go + touch -t $(BEGINNING_OF_TIME) $(srcdir)/ice-9/eval.scm + touch -r $(srcdir)/ice-9/eval.scm ice-9/eval.go + touch -r $(srcdir)/ice-9/eval.scm ice-9/eval.go.stamp + CLEANFILES += ice-9/eval.go ice-9/eval.go.stamp + nobase_mod_DATA += ice-9/eval.scm + nobase_ccache_DATA += ice-9/eval.go + EXTRA_DIST += ice-9/eval.scm + + # We can compile these in any order, but it's fastest if we compile + # psyntax and boot-9 first, then the compiler itself, then the rest of + # the code. + SOURCES = \ + ice-9/psyntax-pp.scm \ + ice-9/boot-9.scm \ + \ + language/tree-il.scm \ + language/glil.scm \ + language/assembly.scm \ + $(TREE_IL_LANG_SOURCES) \ + $(GLIL_LANG_SOURCES) \ + $(ASSEMBLY_LANG_SOURCES) \ + $(BYTECODE_LANG_SOURCES) \ + $(OBJCODE_LANG_SOURCES) \ + $(VALUE_LANG_SOURCES) \ + $(SCHEME_LANG_SOURCES) \ + $(SYSTEM_BASE_SOURCES) \ + \ + $(ICE_9_SOURCES) \ + $(SRFI_SOURCES) \ + $(RNRS_SOURCES) \ + $(OOP_SOURCES) \ + $(SYSTEM_SOURCES) \ + $(SCRIPTS_SOURCES) \ + $(ECMASCRIPT_LANG_SOURCES) \ ++ $(ELISP_LANG_SOURCES) \ $(BRAINFUCK_LANG_SOURCES) ## test.scm is not currently installed. - EXTRA_DIST += ice-9/test.scm ice-9/compile-psyntax.scm ice-9/ChangeLog-2008 + EXTRA_DIST += \ + ice-9/test.scm \ + ice-9/compile-psyntax.scm \ + ice-9/quasisyntax.scm \ + ice-9/ChangeLog-2008 # We expect this to never be invoked when there is not already # ice-9/psyntax-pp.scm in %load-path, since compile-psyntax.scm depends @@@ -69,11 -82,9 +83,9 @@@ ice-9/psyntax-pp.scm: ice-9/psyntax.sc $(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm SCHEME_LANG_SOURCES = \ - language/scheme/compile-ghil.scm \ language/scheme/spec.scm \ language/scheme/compile-tree-il.scm \ - language/scheme/decompile-tree-il.scm \ - language/scheme/inline.scm + language/scheme/decompile-tree-il.scm TREE_IL_LANG_SOURCES = \ language/tree-il/primitives.scm \ @@@ -84,9 -95,6 +96,6 @@@ language/tree-il/compile-glil.scm \ language/tree-il/spec.scm - GHIL_LANG_SOURCES = \ - language/ghil.scm language/ghil/spec.scm language/ghil/compile-glil.scm - GLIL_LANG_SOURCES = \ language/glil/spec.scm language/glil/compile-assembly.scm \ language/glil/decompile-assembly.scm @@@ -117,6 -125,6 +126,17 @@@ ECMASCRIPT_LANG_SOURCES = language/ecmascript/compile-tree-il.scm \ language/ecmascript/spec.scm ++ELISP_LANG_SOURCES = \ ++ language/elisp/lexer.scm \ ++ language/elisp/parser.scm \ ++ language/elisp/bindings.scm \ ++ language/elisp/compile-tree-il.scm \ ++ language/elisp/runtime.scm \ ++ language/elisp/runtime/function-slot.scm \ ++ language/elisp/runtime/macro-slot.scm \ ++ language/elisp/runtime/value-slot.scm \ ++ language/elisp/spec.scm ++ BRAINFUCK_LANG_SOURCES = \ language/brainfuck/parse.scm \ language/brainfuck/compile-scheme.scm \ @@@ -144,8 -152,14 +164,14 @@@ SCRIPTS_SOURCES = scripts/read-rfc822.scm \ scripts/snarf-guile-m4-docs.scm + SYSTEM_BASE_SOURCES = \ + system/base/pmatch.scm \ + system/base/syntax.scm \ + system/base/compile.scm \ + system/base/language.scm \ + system/base/message.scm + ICE_9_SOURCES = \ - ice-9/boot-9.scm \ ice-9/r4rs.scm \ ice-9/r5rs.scm \ ice-9/and-let-star.scm \ @@@ -262,6 -276,7 +288,7 @@@ EXTRA_DIST += oop/ChangeLog-200 NOCOMP_SOURCES = \ ice-9/gds-client.scm \ ice-9/psyntax.scm \ + ice-9/quasisyntax.scm \ system/repl/describe.scm \ ice-9/debugger/command-loop.scm \ ice-9/debugger/commands.scm \ @@@ -269,7 -284,6 +296,6 @@@ ice-9/debugger/trc.scm \ ice-9/debugger/utils.scm \ ice-9/debugging/example-fns.scm \ - ice-9/debugging/ice-9-debugger-extensions.scm \ ice-9/debugging/steps.scm \ ice-9/debugging/trace.scm \ ice-9/debugging/traps.scm \ diff --combined module/language/assembly.scm index c90947204,a7c47492e..541096c52 --- a/module/language/assembly.scm +++ b/module/language/assembly.scm @@@ -28,8 -28,8 +28,8 @@@ assembly-pack assembly-unpack object->assembly assembly->object)) - ;; nargs, nrest, nlocs, len, metalen, padding - (define *program-header-len* (+ 1 1 2 4 4 4)) + ;; len, metalen + (define *program-header-len* (+ 4 4)) ;; lengths are encoded in 3 bytes (define *len-len* 3) @@@ -49,7 -49,7 +49,7 @@@ (+ 1 *len-len* (string-length str))) ((load-array ,bv) (+ 1 *len-len* (bytevector-length bv))) - ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code) + ((load-program ,labels ,len ,meta . ,code) (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0))) ((,inst . _) (guard (>= (instruction-length inst) 0)) (+ 1 (instruction-length inst))) @@@ -72,7 -72,7 +72,7 @@@ '(nop))) (define (align-block addr) - (code-alignment addr *block-alignment* 0)) + '()) (define (align-code code addr alignment header-len) `(,@(code-alignment addr alignment header-len) @@@ -108,7 -108,6 +108,7 @@@ (define (object->assembly x) (cond ((eq? x #t) `(make-true)) ((eq? x #f) `(make-false)) + ((eq? x %nil) `(make-nil)) ((null? x) `(make-eol)) ((and (integer? x) (exact? x)) (cond ((and (<= -128 x) (< x 128)) @@@ -138,7 -137,6 +138,7 @@@ (pmatch code ((make-true) #t) ((make-false) #f) ;; FIXME: Same as the `else' case! + ((make-nil) %nil) ((make-eol) '()) ((make-int8 ,n) (if (< n 128) n (- n 256))) diff --combined module/language/elisp/compile-tree-il.scm index b54f7f60c,000000000..9778d1a59 mode 100644,000000..100644 --- a/module/language/elisp/compile-tree-il.scm +++ b/module/language/elisp/compile-tree-il.scm @@@ -1,880 -1,0 +1,890 @@@ +;;; Guile Emacs Lisp + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by - ;; the Free Software Foundation; either version 2, or (at your option) ++;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language elisp compile-tree-il) + #:use-module (language elisp bindings) + #:use-module (language tree-il) + #:use-module (system base pmatch) + #:use-module (system base compile) + #:use-module (srfi srfi-1) + #:export (compile-tree-il)) + + +; Certain common parameters (like the bindings data structure or compiler +; options) are not always passed around but accessed using fluids to simulate +; dynamic binding (hey, this is about elisp). + +; The bindings data structure to keep track of symbol binding related data. +(define bindings-data (make-fluid)) + +; Store for which symbols (or all/none) void checks are disabled. +(define disable-void-check (make-fluid)) + +; Store which symbols (or all/none) should always be bound lexically, even +; with ordinary let and as lambda arguments. +(define always-lexical (make-fluid)) + + +; Find the source properties of some parsed expression if there are any +; associated with it. + +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (not (null? props)) + props)))) + + +; Values to use for Elisp's nil and t. + +(define (nil-value loc) (make-const loc (@ (language elisp runtime) nil-value))) +(define (t-value loc) (make-const loc (@ (language elisp runtime) t-value))) + + +; Modules that contain the value and function slot bindings. + +(define runtime '(language elisp runtime)) +(define macro-slot '(language elisp runtime macro-slot)) +(define value-slot (@ (language elisp runtime) value-slot-module)) +(define function-slot (@ (language elisp runtime) function-slot-module)) + + +; The backquoting works the same as quasiquotes in Scheme, but the forms are +; named differently; to make easy adaptions, we define these predicates checking +; for a symbol being the car of an unquote/unquote-splicing/backquote form. + +(define (backquote? sym) + (and (symbol? sym) (eq? sym '\`))) + +(define (unquote? sym) + (and (symbol? sym) (eq? sym '\,))) + +(define (unquote-splicing? sym) + (and (symbol? sym) (eq? sym '\,@))) + + +; Build a call to a primitive procedure nicely. + +(define (call-primitive loc sym . args) + (make-application loc (make-primitive-ref loc sym) args)) + + +; Error reporting routine for syntax/compilation problems or build code for +; a runtime-error output. + +(define (report-error loc . args) + (apply error args)) + +(define (runtime-error loc msg . args) + (make-application loc (make-primitive-ref loc 'error) + (cons (make-const loc msg) args))) + + +; Generate code to ensure a global symbol is there for further use of a given +; symbol. In general during the compilation, those needed are only tracked with +; the bindings data structure. Afterwards, however, for all those needed +; symbols the globals are really generated with this routine. + +(define (generate-ensure-global loc sym module) + (make-application loc (make-module-ref loc runtime 'ensure-fluid! #t) + (list (make-const loc module) + (make-const loc sym)))) + + +; See if we should do a void-check for a given variable. That means, check +; that this check is not disabled via the compiler options for this symbol. +; Disabling of void check is only done for the value-slot module! + +(define (want-void-check? sym module) + (let ((disabled (fluid-ref disable-void-check))) + (or (not (equal? module value-slot)) + (and (not (eq? disabled 'all)) + (not (memq sym disabled)))))) + + +; Build a construct that establishes dynamic bindings for certain variables. +; We may want to choose between binding with fluids and with-fluids* and +; using just ordinary module symbols and setting/reverting their values with +; a dynamic-wind. + +(define (let-dynamic loc syms module vals body) + (call-primitive loc 'with-fluids* + (make-application loc (make-primitive-ref loc 'list) + (map (lambda (sym) + (make-module-ref loc module sym #t)) + syms)) + (make-application loc (make-primitive-ref loc 'list) vals) - (make-lambda loc '() '() '() body))) ++ (make-lambda loc '() ++ (make-lambda-case #f '() #f #f #f '() '() body #f)))) + + +; Handle access to a variable (reference/setting) correctly depending on +; whether it is currently lexically or dynamically bound. +; lexical access is done only for references to the value-slot module! + +(define (access-variable loc sym module handle-lexical handle-dynamic) + (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym))) + (if (and lexical (equal? module value-slot)) + (handle-lexical lexical) + (handle-dynamic)))) + + +; Generate code to reference a variable. +; For references in the value-slot module, we may want to generate a lexical +; reference instead if the variable has a lexical binding. + +(define (reference-variable loc sym module) + (access-variable loc sym module + (lambda (lexical) + (make-lexical-ref loc lexical lexical)) + (lambda () + (mark-global-needed! (fluid-ref bindings-data) sym module) + (call-primitive loc 'fluid-ref + (make-module-ref loc module sym #t))))) + + +; Reference a variable and error if the value is void. + +(define (reference-with-check loc sym module) + (if (want-void-check? sym module) + (let ((var (gensym))) + (make-let loc '(value) `(,var) `(,(reference-variable loc sym module)) + (make-conditional loc + (call-primitive loc 'eq? + (make-module-ref loc runtime 'void #t) + (make-lexical-ref loc 'value var)) + (runtime-error loc "variable is void:" (make-const loc sym)) + (make-lexical-ref loc 'value var)))) + (reference-variable loc sym module))) + + +; Generate code to set a variable. +; Just as with reference-variable, in case of a reference to value-slot, +; we want to generate a lexical set when the variable has a lexical binding. + +(define (set-variable! loc sym module value) + (access-variable loc sym module + (lambda (lexical) + (make-lexical-set loc lexical lexical value)) + (lambda () + (mark-global-needed! (fluid-ref bindings-data) sym module) + (call-primitive loc 'fluid-set! + (make-module-ref loc module sym #t) + value)))) + + +; Process the bindings part of a let or let* expression; that is, check for +; correctness and bring it to the form ((sym1 . val1) (sym2 . val2) ...). + +(define (process-let-bindings loc bindings) + (map (lambda (b) + (if (symbol? b) + (cons b 'nil) + (if (or (not (list? b)) + (not (= (length b) 2))) + (report-error loc "expected symbol or list of 2 elements in let") + (if (not (symbol? (car b))) + (report-error loc "expected symbol in let") + (cons (car b) (cadr b)))))) + bindings)) + + +; Split the let bindings into a list to be done lexically and one dynamically. +; A symbol will be bound lexically if and only if: +; We're processing a lexical-let (i.e. module is 'lexical), OR +; we're processing a value-slot binding AND +; the symbol is already lexically bound or it is always lexical. + +(define (bind-lexically? sym module) + (or (eq? module 'lexical) + (and (equal? module value-slot) + (let ((always (fluid-ref always-lexical))) + (or (eq? always 'all) + (memq sym always) + (get-lexical-binding (fluid-ref bindings-data) sym)))))) + +(define (split-let-bindings bindings module) + (let iterate ((tail bindings) + (lexical '()) + (dynamic '())) + (if (null? tail) + (values (reverse lexical) (reverse dynamic)) + (if (bind-lexically? (caar tail) module) + (iterate (cdr tail) (cons (car tail) lexical) dynamic) + (iterate (cdr tail) lexical (cons (car tail) dynamic)))))) + + +; Compile let and let* expressions. The code here is used both for let/let* +; and flet/flet*, just with a different bindings module. +; +; A special module value 'lexical means that we're doing a lexical-let instead +; and the bindings should not be saved to globals at all but be done with the +; lexical framework instead. + +; Let is done with a single call to let-dynamic binding them locally to new +; values all "at once". If there is at least one variable to bind lexically +; among the bindings, we first do a let for all of them to evaluate all +; values before any bindings take place, and then call let-dynamic for the +; variables to bind dynamically. +(define (generate-let loc module bindings body) + (let ((bind (process-let-bindings loc bindings))) + (call-with-values + (lambda () + (split-let-bindings bind module)) + (lambda (lexical dynamic) + (for-each (lambda (sym) + (mark-global-needed! (fluid-ref bindings-data) sym module)) + (map car dynamic)) + (let ((make-values (lambda (for) + (map (lambda (el) + (compile-expr (cdr el))) + for))) + (make-body (lambda () + (make-sequence loc (map compile-expr body))))) + (if (null? lexical) + (let-dynamic loc (map car dynamic) module + (make-values dynamic) (make-body)) + (let* ((lexical-syms (map (lambda (el) (gensym)) lexical)) + (dynamic-syms (map (lambda (el) (gensym)) dynamic)) + (all-syms (append lexical-syms dynamic-syms)) + (vals (append (make-values lexical) (make-values dynamic)))) + (make-let loc all-syms all-syms vals + (with-lexical-bindings (fluid-ref bindings-data) + (map car lexical) lexical-syms + (lambda () + (if (null? dynamic) + (make-body) + (let-dynamic loc (map car dynamic) module + (map (lambda (sym) + (make-lexical-ref loc sym sym)) + dynamic-syms) + (make-body))))))))))))) + + +; Let* is compiled to a cascaded set of "small lets" for each binding in turn +; so that each one already sees the preceding bindings. +(define (generate-let* loc module bindings body) + (let ((bind (process-let-bindings loc bindings))) + (begin + (for-each (lambda (sym) + (if (not (bind-lexically? sym module)) + (mark-global-needed! (fluid-ref bindings-data) sym module))) + (map car bind)) + (let iterate ((tail bind)) + (if (null? tail) + (make-sequence loc (map compile-expr body)) + (let ((sym (caar tail)) + (value (compile-expr (cdar tail)))) + (if (bind-lexically? sym module) + (let ((target (gensym))) + (make-let loc `(,target) `(,target) `(,value) + (with-lexical-bindings (fluid-ref bindings-data) + `(,sym) `(,target) + (lambda () + (iterate (cdr tail)))))) + (let-dynamic loc + `(,(caar tail)) module `(,value) + (iterate (cdr tail)))))))))) + + +; Split the argument list of a lambda expression into required, optional and +; rest arguments and also check it is actually valid. +; Additionally, we create a list of all "local variables" (that is, required, +; optional and rest arguments together) and also this one split into those to +; be bound lexically and dynamically. +; Returned is as multiple values: required optional rest lexical dynamic + +(define (bind-arg-lexical? arg) + (let ((always (fluid-ref always-lexical))) + (or (eq? always 'all) + (memq arg always)))) + +(define (split-lambda-arguments loc args) + (let iterate ((tail args) + (mode 'required) + (required '()) + (optional '()) + (lexical '()) + (dynamic '())) + (cond + + ((null? tail) + (let ((final-required (reverse required)) + (final-optional (reverse optional)) + (final-lexical (reverse lexical)) + (final-dynamic (reverse dynamic))) + (values final-required final-optional #f + final-lexical final-dynamic))) + + ((and (eq? mode 'required) + (eq? (car tail) '&optional)) + (iterate (cdr tail) 'optional required optional lexical dynamic)) + + ((eq? (car tail) '&rest) + (if (or (null? (cdr tail)) + (not (null? (cddr tail)))) + (report-error loc "expected exactly one symbol after &rest") + (let* ((rest (cadr tail)) + (rest-lexical (bind-arg-lexical? rest)) + (final-required (reverse required)) + (final-optional (reverse optional)) + (final-lexical (reverse (if rest-lexical + (cons rest lexical) + lexical))) + (final-dynamic (reverse (if rest-lexical + dynamic + (cons rest dynamic))))) + (values final-required final-optional rest + final-lexical final-dynamic)))) + + (else + (if (not (symbol? (car tail))) + (report-error loc "expected symbol in argument list, got" (car tail)) + (let* ((arg (car tail)) + (bind-lexical (bind-arg-lexical? arg)) + (new-lexical (if bind-lexical + (cons arg lexical) + lexical)) + (new-dynamic (if bind-lexical + dynamic + (cons arg dynamic)))) + (case mode + ((required) (iterate (cdr tail) mode + (cons arg required) optional + new-lexical new-dynamic)) + ((optional) (iterate (cdr tail) mode + required (cons arg optional) + new-lexical new-dynamic)) + (else + (error "invalid mode in split-lambda-arguments" mode))))))))) + + +; Compile a lambda expression. Things get a little complicated because TreeIL +; does not allow optional arguments but only one rest argument, and also the +; rest argument should be nil instead of '() for no values given. Because of +; this, we have to do a little preprocessing to get everything done before the +; real body is called. +; +; (lambda (a &optional b &rest c) body) should become: +; (lambda (a_ . rest_) +; (with-fluids* (list a b c) (list a_ nil nil) +; (lambda () +; (if (not (null? rest_)) +; (begin +; (fluid-set! b (car rest_)) +; (set! rest_ (cdr rest_)) +; (if (not (null? rest_)) +; (fluid-set! c rest_)))) +; body))) +; +; This is formulated very imperatively, but I think in this case that is quite +; clear and better than creating a lot of nested let's. +; +; Another thing we have to be aware of is that lambda arguments are usually +; dynamically bound, even when a lexical binding is in tact for a symbol. +; For symbols that are marked as 'always lexical' however, we bind them here +; lexically, too -- and thus we get them out of the let-dynamic call and +; register a lexical binding for them (the lexical target variable is already +; there, namely the real lambda argument from TreeIL). +; For optional arguments that are lexically bound we need to create the lexical +; bindings though with an additional let, as those arguments are not part of the +; ordinary argument list. + +(define (compile-lambda loc args body) + (if (not (list? args)) + (report-error loc "expected list for argument-list" args)) + (if (null? body) + (report-error loc "function body might not be empty")) + (call-with-values + (lambda () + (split-lambda-arguments loc args)) + (lambda (required optional rest lexical dynamic) + (let* ((make-sym (lambda (sym) (gensym))) + (required-sym (map make-sym required)) + (required-pairs (map cons required required-sym)) + (have-real-rest (or rest (not (null? optional)))) + (rest-sym (if have-real-rest (gensym) '())) + (rest-name (if rest rest rest-sym)) + (rest-lexical (and rest (memq rest lexical))) + (rest-dynamic (and rest (not rest-lexical))) + (real-args (append required-sym rest-sym)) + (arg-names (append required rest-name)) + (lex-optionals (lset-intersection eq? optional lexical)) + (dyn-optionals (lset-intersection eq? optional dynamic)) + (optional-sym (map make-sym lex-optionals)) + (optional-lex-pairs (map cons lex-optionals optional-sym)) + (find-required-pairs (lambda (filter) + (lset-intersection (lambda (name-sym el) + (eq? (car name-sym) + el)) + required-pairs filter))) + (required-lex-pairs (find-required-pairs lexical)) + (rest-pair (if rest-lexical `((,rest . ,rest-sym)) '())) + (all-lex-pairs (append required-lex-pairs optional-lex-pairs + rest-pair))) + (for-each (lambda (sym) + (mark-global-needed! (fluid-ref bindings-data) + sym value-slot)) + dynamic) + (with-dynamic-bindings (fluid-ref bindings-data) dynamic + (lambda () + (with-lexical-bindings (fluid-ref bindings-data) + (map car all-lex-pairs) + (map cdr all-lex-pairs) + (lambda () - (make-lambda loc - arg-names real-args '() ++ (make-lambda loc '() ++ (make-lambda-case ++ #f required #f ++ (if have-real-rest rest-name #f) ++ #f '() ++ (if have-real-rest ++ (append required-sym (list rest-sym)) ++ required-sym) + (let* ((init-req (map (lambda (name-sym) + (make-lexical-ref loc (car name-sym) + (cdr name-sym))) + (find-required-pairs dynamic))) + (init-nils (map (lambda (sym) (nil-value loc)) + (if rest-dynamic + `(,@dyn-optionals ,rest-sym) + dyn-optionals))) + (init (append init-req init-nils)) + (func-body (make-sequence loc + `(,(process-optionals loc optional + rest-name rest-sym) + ,(process-rest loc rest + rest-name rest-sym) + ,@(map compile-expr body)))) + (dynlet (let-dynamic loc dynamic value-slot + init func-body)) + (full-body (if (null? dynamic) func-body dynlet))) + (if (null? optional-sym) + full-body + (make-let loc + optional-sym optional-sym + (map (lambda (sym) (nil-value loc)) optional-sym) - full-body)))))))))))) ++ full-body))) ++ #f)))))))))) + +; Build the code to handle setting of optional arguments that are present +; and updating the rest list. +(define (process-optionals loc optional rest-name rest-sym) + (let iterate ((tail optional)) + (if (null? tail) + (make-void loc) + (make-conditional loc + (call-primitive loc 'null? (make-lexical-ref loc rest-name rest-sym)) + (make-void loc) + (make-sequence loc + (list (set-variable! loc (car tail) value-slot + (call-primitive loc 'car + (make-lexical-ref loc rest-name rest-sym))) + (make-lexical-set loc rest-name rest-sym + (call-primitive loc 'cdr + (make-lexical-ref loc rest-name rest-sym))) + (iterate (cdr tail)))))))) + +; This builds the code to set the rest variable to nil if it is empty. +(define (process-rest loc rest rest-name rest-sym) + (let ((rest-empty (call-primitive loc 'null? + (make-lexical-ref loc rest-name rest-sym)))) + (cond + (rest + (make-conditional loc rest-empty + (make-void loc) + (set-variable! loc rest value-slot + (make-lexical-ref loc rest-name rest-sym)))) + ((not (null? rest-sym)) + (make-conditional loc rest-empty + (make-void loc) + (runtime-error loc "too many arguments and no rest argument"))) + (else (make-void loc))))) + + +; Handle the common part of defconst and defvar, that is, checking for a correct +; doc string and arguments as well as maybe in the future handling the docstring +; somehow. + +(define (handle-var-def loc sym doc) + (cond + ((not (symbol? sym)) (report-error loc "expected symbol, got" sym)) + ((> (length doc) 1) (report-error loc "too many arguments to defvar")) + ((and (not (null? doc)) (not (string? (car doc)))) + (report-error loc "expected string as third argument of defvar, got" + (car doc))) + ; TODO: Handle doc string if present. + (else #t))) + + +; Handle macro bindings. + +(define (is-macro? sym) + (module-defined? (resolve-interface macro-slot) sym)) + +(define (define-macro! loc sym definition) + (let ((resolved (resolve-module macro-slot))) + (if (is-macro? sym) + (report-error loc "macro is already defined" sym) + (begin + (module-define! resolved sym definition) + (module-export! resolved (list sym)))))) + +(define (get-macro sym) + (module-ref (resolve-module macro-slot) sym)) + + +; See if a (backquoted) expression contains any unquotes. + +(define (contains-unquotes? expr) + (if (pair? expr) + (if (or (unquote? (car expr)) (unquote-splicing? (car expr))) + #t + (or (contains-unquotes? (car expr)) + (contains-unquotes? (cdr expr)))) + #f)) + + +; Process a backquoted expression by building up the needed cons/append calls. +; For splicing, it is assumed that the expression spliced in evaluates to a +; list. The emacs manual does not really state either it has to or what to do +; if it does not, but Scheme explicitly forbids it and this seems reasonable +; also for elisp. + +(define (unquote-cell? expr) + (and (list? expr) (= (length expr) 2) (unquote? (car expr)))) +(define (unquote-splicing-cell? expr) + (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr)))) + +(define (process-backquote loc expr) + (if (contains-unquotes? expr) + (if (pair? expr) + (if (or (unquote-cell? expr) (unquote-splicing-cell? expr)) + (compile-expr (cadr expr)) + (let* ((head (car expr)) + (processed-tail (process-backquote loc (cdr expr))) + (head-is-list-2 (and (list? head) (= (length head) 2))) + (head-unquote (and head-is-list-2 (unquote? (car head)))) + (head-unquote-splicing (and head-is-list-2 + (unquote-splicing? (car head))))) + (if head-unquote-splicing + (call-primitive loc 'append + (compile-expr (cadr head)) processed-tail) + (call-primitive loc 'cons + (if head-unquote + (compile-expr (cadr head)) + (process-backquote loc head)) + processed-tail)))) + (report-error loc "non-pair expression contains unquotes" expr)) + (make-const loc expr))) + + +; Temporarily update a list of symbols that are handled specially (disabled +; void check or always lexical) for compiling body. +; We need to handle special cases for already all / set to all and the like. + +(define (with-added-symbols loc fluid syms body) + (if (null? body) + (report-error loc "symbol-list construct has empty body")) + (if (not (or (eq? syms 'all) + (and (list? syms) (and-map symbol? syms)))) + (report-error loc "invalid symbol list" syms)) + (let ((old (fluid-ref fluid)) + (make-body (lambda () + (make-sequence loc (map compile-expr body))))) + (if (eq? old 'all) + (make-body) + (let ((new (if (eq? syms 'all) + 'all + (append syms old)))) + (with-fluids ((fluid new)) + (make-body)))))) + + +; Compile a symbol expression. This is a variable reference or maybe some +; special value like nil. + +(define (compile-symbol loc sym) + (case sym + ((nil) (nil-value loc)) + ((t) (t-value loc)) + (else (reference-with-check loc sym value-slot)))) + + +; Compile a pair-expression (that is, any structure-like construct). + +(define (compile-pair loc expr) + (pmatch expr + + ((progn . ,forms) + (make-sequence loc (map compile-expr forms))) + + ((if ,condition ,ifclause) + (make-conditional loc (compile-expr condition) + (compile-expr ifclause) + (nil-value loc))) + ((if ,condition ,ifclause ,elseclause) + (make-conditional loc (compile-expr condition) + (compile-expr ifclause) + (compile-expr elseclause))) + ((if ,condition ,ifclause . ,elses) + (make-conditional loc (compile-expr condition) + (compile-expr ifclause) + (make-sequence loc (map compile-expr elses)))) + + ; defconst and defvar are kept here in the compiler (rather than doing them + ; as macros) for if we may want to handle the docstring somehow. + + ((defconst ,sym ,value . ,doc) + (if (handle-var-def loc sym doc) + (make-sequence loc + (list (set-variable! loc sym value-slot (compile-expr value)) + (make-const loc sym))))) + + ((defvar ,sym) (make-const loc sym)) + ((defvar ,sym ,value . ,doc) + (if (handle-var-def loc sym doc) + (make-sequence loc + (list (make-conditional loc + (call-primitive loc 'eq? + (make-module-ref loc runtime 'void #t) + (reference-variable loc sym value-slot)) + (set-variable! loc sym value-slot + (compile-expr value)) + (make-void loc)) + (make-const loc sym))))) + + ; Build a set form for possibly multiple values. The code is not formulated + ; tail recursive because it is clearer this way and large lists of symbol + ; expression pairs are very unlikely. + ((setq . ,args) (guard (not (null? args))) + (make-sequence loc + (let iterate ((tail args)) + (let ((sym (car tail)) + (tailtail (cdr tail))) + (if (not (symbol? sym)) + (report-error loc "expected symbol in setq") + (if (null? tailtail) + (report-error loc "missing value for symbol in setq" sym) + (let* ((val (compile-expr (car tailtail))) + (op (set-variable! loc sym value-slot val))) + (if (null? (cdr tailtail)) + (let* ((temp (gensym)) + (ref (make-lexical-ref loc temp temp))) + (list (make-let loc `(,temp) `(,temp) `(,val) + (make-sequence loc + (list (set-variable! loc sym value-slot ref) + ref))))) + (cons (set-variable! loc sym value-slot val) + (iterate (cdr tailtail))))))))))) + + ; All lets (let, flet, lexical-let and let* forms) are done using the + ; generate-let/generate-let* methods. + + ((let ,bindings . ,body) (guard (and (list? bindings) + (not (null? bindings)) + (not (null? body)))) + (generate-let loc value-slot bindings body)) + ((lexical-let ,bindings . ,body) (guard (and (list? bindings) + (not (null? bindings)) + (not (null? body)))) + (generate-let loc 'lexical bindings body)) + ((flet ,bindings . ,body) (guard (and (list? bindings) + (not (null? bindings)) + (not (null? body)))) + (generate-let loc function-slot bindings body)) + + ((let* ,bindings . ,body) (guard (and (list? bindings) + (not (null? bindings)) + (not (null? body)))) + (generate-let* loc value-slot bindings body)) + ((lexical-let* ,bindings . ,body) (guard (and (list? bindings) + (not (null? bindings)) + (not (null? body)))) + (generate-let* loc 'lexical bindings body)) + ((flet* ,bindings . ,body) (guard (and (list? bindings) + (not (null? bindings)) + (not (null? body)))) + (generate-let* loc function-slot bindings body)) + + ; Temporarily disable void checks or set symbols as always lexical only + ; for the lexical scope of a construct. + + ((without-void-checks ,syms . ,body) + (with-added-symbols loc disable-void-check syms body)) + + ((with-always-lexical ,syms . ,body) + (with-added-symbols loc always-lexical syms body)) + + ; guile-ref allows building TreeIL's module references from within + ; elisp as a way to access data within + ; the Guile universe. The module and symbol referenced are static values, + ; just like (@ module symbol) does! + ((guile-ref ,module ,sym) (guard (and (list? module) (symbol? sym))) + (make-module-ref loc module sym #t)) + + ; guile-primitive allows to create primitive references, which are still + ; a little faster. + ((guile-primitive ,sym) (guard (symbol? sym)) + (make-primitive-ref loc sym)) + + ; A while construct is transformed into a tail-recursive loop like this: + ; (letrec ((iterate (lambda () + ; (if condition + ; (begin body + ; (iterate)) + ; %nil)))) + ; (iterate)) + ; + ; As letrec is not directly accessible from elisp, while is implemented here + ; instead of with a macro. + ((while ,condition . ,body) + (let* ((itersym (gensym)) + (compiled-body (map compile-expr body)) + (iter-call (make-application loc + (make-lexical-ref loc 'iterate itersym) + (list))) + (full-body (make-sequence loc + `(,@compiled-body ,iter-call))) + (lambda-body (make-conditional loc + (compile-expr condition) + full-body + (nil-value loc))) - (iter-thunk (make-lambda loc '() '() '() lambda-body))) ++ (iter-thunk (make-lambda loc '() ++ (make-lambda-case #f '() #f #f #f '() '() ++ lambda-body #f)))) + (make-letrec loc '(iterate) (list itersym) (list iter-thunk) + iter-call))) + + ; Either (lambda ...) or (function (lambda ...)) denotes a lambda-expression + ; that should be compiled. + ((lambda ,args . ,body) + (compile-lambda loc args body)) + ((function (lambda ,args . ,body)) + (compile-lambda loc args body)) + + ; Build a lambda and also assign it to the function cell of some symbol. + ; This is no macro as we might want to honour the docstring at some time; + ; just as with defvar/defconst. + ((defun ,name ,args . ,body) + (if (not (symbol? name)) + (report-error loc "expected symbol as function name" name) + (make-sequence loc + (list (set-variable! loc name function-slot + (compile-lambda loc args body)) + (make-const loc name))))) + + ; Define a macro (this is done directly at compile-time!). + ; FIXME: Recursive macros don't work! + ((defmacro ,name ,args . ,body) + (if (not (symbol? name)) + (report-error loc "expected symbol as macro name" name) + (let* ((tree-il (with-fluids ((bindings-data (make-bindings))) + (compile-lambda loc args body))) + (object (compile tree-il #:from 'tree-il #:to 'value))) + (define-macro! loc name object) + (make-const loc name)))) + + ; XXX: Maybe we could implement backquotes in macros, too. + ((,backq ,val) (guard (backquote? backq)) + (process-backquote loc val)) + + ; XXX: Why do we need 'quote here instead of quote? + (('quote ,val) + (make-const loc val)) + + ; Macro calls are simply expanded and recursively compiled. + ((,macro . ,args) (guard (and (symbol? macro) (is-macro? macro))) + (let ((expander (get-macro macro))) + (compile-expr (apply expander args)))) + + ; Function calls using (function args) standard notation; here, we have to + ; take the function value of a symbol if it is one. It seems that functions + ; in form of uncompiled lists are not supported in this syntax, so we don't + ; have to care for them. + ((,func . ,args) + (make-application loc + (if (symbol? func) + (reference-with-check loc func function-slot) + (compile-expr func)) + (map compile-expr args))) + + (else + (report-error loc "unrecognized elisp" expr)))) + + +; Compile a single expression to TreeIL. + +(define (compile-expr expr) + (let ((loc (location expr))) + (cond + ((symbol? expr) + (compile-symbol loc expr)) + ((pair? expr) + (compile-pair loc expr)) + (else (make-const loc expr))))) + + +; Process the compiler options. +; FIXME: Why is '(()) passed as options by the REPL? + +(define (valid-symbol-list-arg? value) + (or (eq? value 'all) + (and (list? value) (and-map symbol? value)))) + +(define (process-options! opt) + (if (and (not (null? opt)) + (not (equal? opt '(())))) + (if (null? (cdr opt)) + (report-error #f "Invalid compiler options" opt) + (let ((key (car opt)) + (value (cadr opt))) + (case key + ((#:disable-void-check) + (if (valid-symbol-list-arg? value) + (fluid-set! disable-void-check value) + (report-error #f "Invalid value for #:disable-void-check" value))) + ((#:always-lexical) + (if (valid-symbol-list-arg? value) + (fluid-set! always-lexical value) + (report-error #f "Invalid value for #:always-lexical" value))) + (else (report-error #f "Invalid compiler option" key))))))) + + +; Entry point for compilation to TreeIL. +; This creates the bindings data structure, and after compiling the main +; expression we need to make sure all globals for symbols used during the +; compilation are created using the generate-ensure-global function. + +(define (compile-tree-il expr env opts) + (values + (with-fluids ((bindings-data (make-bindings)) + (disable-void-check '()) + (always-lexical '())) + (process-options! opts) + (let ((loc (location expr)) + (compiled (compile-expr expr))) + (make-sequence loc + `(,@(map-globals-needed (fluid-ref bindings-data) + (lambda (mod sym) + (generate-ensure-global loc sym mod))) + ,compiled)))) + env + env)) diff --combined module/language/elisp/spec.scm index f89e0c1d4,000000000..072ccb9a4 mode 100644,000000..100644 --- a/module/language/elisp/spec.scm +++ b/module/language/elisp/spec.scm @@@ -1,32 -1,0 +1,32 @@@ +;;; Guile Emac Lisp + - ;; Copyright (C) 2001 Free Software Foundation, Inc. ++;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language elisp spec) + #:use-module (language elisp compile-tree-il) + #:use-module (language elisp parser) + #:use-module (system base language) + #:export (elisp)) + +(define-language elisp + #:title "Emacs Lisp" + #:version "0.0" - #:reader (lambda () (read-elisp (current-input-port))) ++ #:reader (lambda (port env) (read-elisp port)) + #:printer write + #:compilers `((tree-il . ,compile-tree-il))) diff --combined module/language/glil/decompile-assembly.scm index 69aa1eb5c,937a67858..916353818 --- a/module/language/glil/decompile-assembly.scm +++ b/module/language/glil/decompile-assembly.scm @@@ -31,9 -31,8 +31,8 @@@ (define (decompile-toplevel x) (pmatch x - ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body) - (decompile-load-program nargs nrest nlocs - (decompile-meta meta) + ((load-program ,labels ,len ,meta . ,body) + (decompile-load-program (decompile-meta meta) body labels #f)) (else (error "invalid assembly" x)))) @@@ -56,7 -55,7 +55,7 @@@ ((glil-program? (car in)) (lp (cdr in) (cons (car in) out))) (else (lp (cdr in) (cons (make-glil-const (car l)) out)))))) - (define (decompile-load-program nargs nrest nlocs meta body labels + (define (decompile-load-program meta body labels objects) (let ((glil-labels (sort (map (lambda (x) (cons (cdr x) (make-glil-label (car x)))) @@@ -100,7 -99,7 +99,7 @@@ (cond ((null? in) (or (null? stack) (error "leftover stack insts" stack body)) - (make-glil-program nargs nrest nlocs props (reverse out) #f)) + (make-glil-program props (reverse out))) ((pop-bindings! pos) => (lambda (bindings) (lp in stack @@@ -123,11 -122,9 +122,11 @@@ (lp (cdr in) stack out (1+ pos))) ((make-false) (lp (cdr in) (cons #f stack) out (1+ pos))) + ((make-nil) + (lp (cdr in) (cons %nil stack) out (1+ pos))) - ((load-program ,a ,b ,c ,d ,labels ,sublen ,meta . ,body) + ((load-program ,labels ,sublen ,meta . ,body) (lp (cdr in) - (cons (decompile-load-program a b c d (decompile-meta meta) + (cons (decompile-load-program (decompile-meta meta) body labels (car stack)) (cdr stack)) out diff --combined test-suite/Makefile.am index cf575a214,d08aab7ff..9ac4c080f --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@@ -26,15 -26,13 +26,15 @@@ SCM_TESTS = tests/alist.test tests/arbiters.test \ tests/asm-to-bytecode.test \ tests/bit-operations.test \ + tests/brainfuck.test \ tests/bytevectors.test \ tests/c-api.test \ tests/chars.test \ tests/common-list.test \ tests/continuations.test \ tests/elisp.test \ + tests/elisp-compiler.text \ + tests/elisp-reader.text \ - tests/environments.test \ tests/eval.test \ tests/exceptions.test \ tests/filesys.test \ @@@ -50,6 -48,7 +50,7 @@@ tests/i18n.test \ tests/import.test \ tests/interp.test \ + tests/keywords.test \ tests/list.test \ tests/load.test \ tests/modules.test \ @@@ -70,6 -69,7 +71,7 @@@ tests/reader.test \ tests/receive.test \ tests/regexp.test \ + tests/signals.test \ tests/socket.test \ tests/srcprop.test \ tests/srfi-1.test \