[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-55-g5e0253f
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-55-g5e0253f |
|
Date: |
Thu, 27 Jun 2013 20:03:22 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=5e0253f19ef146c46a08fead9d70866f4baa9ca1
The branch, master has been updated
via 5e0253f19ef146c46a08fead9d70866f4baa9ca1 (commit)
via 86d0eb31df4b1a28df74ff3d91de66223291e351 (commit)
via bb97e4abd49e8094e9eb8bf767c696bf7ee1ba7e (commit)
via 0fcc39a0a962e44d509dbb659529165c7ce5b91d (commit)
via bc056057c85162b609437e68ec4eb55839682853 (commit)
via 5da2aae3644a9ff9508db9501c50762f6e19cc97 (commit)
via 39caffe79b3d159590b5ce1ccf8fe28c3d5cfdc6 (commit)
via 1773bc7dd5f4c8a1d13c7cf2015f3a04c9299eeb (commit)
via 385049949aa52b8578334d073b2c63291a5d5274 (commit)
via 9833864171fa54100e97040a4f1007919ff614ad (commit)
from 9b965638e9e6cfe927807dbacc86212cc638967b (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 5e0253f19ef146c46a08fead9d70866f4baa9ca1
Author: Andy Wingo <address@hidden>
Date: Thu Jun 27 19:38:32 2013 +0200
replace <dynset> with primcalls to fluid-set!
* doc/ref/compiler.texi (Tree-IL): Remove mention of <dynset>.
* module/language/scheme/decompile-tree-il.scm (do-decompile):
(choose-output-names): Remove dynset.
* module/language/tree-il.scm (<tree-il>, parse-tree-il):
(unparse-tree-il, make-tree-il-folder, pre-post-order): Remove
<dynset>.
* module/language/tree-il/analyze.scm (analyze-lexicals):
* module/language/tree-il/compile-glil.scm (*primcall-ops*): Add
fluid-set!.
(flatten-lambda-case): Remove <dynset> case.
* module/language/tree-il/cse.scm (cse):
* module/language/tree-il/debug.scm (verify-tree-il): Remove <dynset>
cases.
* module/language/tree-il/effects.scm (make-effects-analyzer): Remove
<dynset> case. Add a primcall fluid-set! case.
* module/language/tree-il/peval.scm (peval): Remove dynset cases.
* module/language/tree-il/primitives.scm (*primitive-expand-table*):
Remove fluid-set! -> dynset transformation.
commit 86d0eb31df4b1a28df74ff3d91de66223291e351
Author: Andy Wingo <address@hidden>
Date: Thu Jun 27 19:28:42 2013 +0200
replace <dynref> with primcalls to fluid-ref
* doc/ref/compiler.texi (Tree-IL): Remove mention of <dynref>.
* module/language/scheme/decompile-tree-il.scm (do-decompile):
(choose-output-names): Remove dynref.
* module/language/tree-il.scm (<tree-il>, parse-tree-il):
(unparse-tree-il, make-tree-il-folder, pre-post-order): Remove
<dynref>.
* module/language/tree-il/analyze.scm (analyze-lexicals):
* module/language/tree-il/compile-glil.scm (*primcall-ops*): Add
fluid-ref.
(flatten-lambda-case): Remove <dynref> case.
* module/language/tree-il/cse.scm (cse):
* module/language/tree-il/debug.scm (verify-tree-il): Remove <dynref>
cases.
* module/language/tree-il/effects.scm (make-effects-analyzer): Remove
<dynref> case. Add a primcall fluid-ref case.
* module/language/tree-il/peval.scm (peval): Remove dynref cases.
* module/language/tree-il/primitives.scm (*primitive-expand-table*):
Remove fluid-ref -> dynref transformation.
commit bb97e4abd49e8094e9eb8bf767c696bf7ee1ba7e
Author: Andy Wingo <address@hidden>
Date: Thu Jun 27 18:49:21 2013 +0200
dynamic-wind in terms of wind and unwind; remove <dynwind>, @dynamic-wind
* doc/ref/compiler.texi: Remove mention of <dynwind>.
* libguile/eval.c (eval): Remove SCM_M_DYNWIND case.
* libguile/expand.c: Remove scm_sym_at_dynamic_wind.
* libguile/memoize.c (do_wind, do_unwind): A couple of hacky subrs. If
we see a wind or unwind primcall, we expand to a call of a quoted subr
value. It works and removes a kind of memoized value from the
interpreter. For the compiler,primcalls to wind and unwind are
handled specially.
(MAKMEMO_DYNWIND): Remove.
(scm_tc16_memoizer): Remove. Yay!
(memoize): Remove speculative lookup for toplevels to see if they are
memoizers: there are no more memoizers. Memoize calls to the wind and
unwind primitives.
(m_dynamic_wind): Remove.
(unmemoize): Remove dynwind case.
(scm_init_memoize): Add wind and unwind local definitions.
* module/ice-9/boot-9.scm (dynamic-wind): Reimplement in terms of "wind"
and "unwind" primitives. These primitives are not exposed to other
modules.
* module/ice-9/eval.scm (primitive-eval): Remove dynwind case.
* module/language/scheme/decompile-tree-il.scm (do-decompile):
(choose-output-names): Remove dynwind cases.
* module/language/tree-il.scm: Remove <dynwind>. Yaaay!
* module/language/tree-il/analyze.scm (analyze-lexicals): Remove dynwind
cases.
* module/language/tree-il/compile-glil.scm (*primcall-ops*): Add wind
and unwind.
(flatten-lambda-case): Remove dynwind case. Yay!
* module/language/tree-il/cse.scm (cse):
* module/language/tree-il/debug.scm (verify-tree-il):
* module/language/tree-il/effects.scm (make-effects-analyzer):
* module/language/tree-il/peval.scm (singly-valued-expression?, peval):
Remove <dywind> cases. Inline primcalls to dynamic-wind. Add
constant folding for thunk?.
* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
Remove @dynamic-wind, and add procedure? and thunk?.
(*effect+exception-free-primitives*): Add procedure? and thunk?.
(*multiply-valued-primitives*): Remove @dynamic-wind.
Remove @dynamic-wind expander.
* test-suite/tests/peval.test ("partial evaluation"): Update tests for
dynwind desugaring.
commit 0fcc39a0a962e44d509dbb659529165c7ce5b91d
Author: Andy Wingo <address@hidden>
Date: Thu Jun 27 12:20:36 2013 +0200
remove @call-with-values memoizer
* libguile/memoize.h:
* libguile/expand.c (scm_sym_at_call_with_values): Remove.
* libguile/memoize.c (memoize, m_call_values, unmemoize): Adapt to
memoize call-with-values primcalls.
* module/ice-9/boot-9.scm (call-with-values): Expand to a
call-with-values primcall.
* module/language/tree-il/compile-glil.scm (flatten-lambda-case): Expect
call-with-values primcall, without the @, and fall back to a normal
call.
* module/language/tree-il/peval.scm (peval): Match bare
call-with-values.
* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
(*multiply-valued-primitives*): Remove @call-with-values.
commit bc056057c85162b609437e68ec4eb55839682853
Author: Andy Wingo <address@hidden>
Date: Thu Jun 27 12:10:37 2013 +0200
remove @call-with-current-continuation memoizer
* module/ice-9/boot-9.scm (call-with-current-continuation): Change to
primcall call-with-current-continuation.
* libguile/memoize.h:
* libguile/expand.c (scm_sym_atcall_cc): Remove.
* libguile/memoize.c (memoize): Memoize call/cc primcalls to
SCM_M_CONT.
(m_call_cc): Remove.
(unmemoize): Unmemoize to call-with-current-continuation.
* module/language/tree-il/compile-glil.scm (flatten-lambda-case): Update
to call-with-current-continuation without @ prefix, and fix fallback
case.
* module/language/tree-il/primitives.scm (*multiply-valued-primitives*):
(*interesting-primitive-names*): Remove
@call-with-current-continuation.
(call/cc): Expand to call-with-current-continuation.
* test-suite/tests/tree-il.test ("call/cc"): Update to use and expect
call-with-current-continuation primcalls / toplevel refs.
commit 5da2aae3644a9ff9508db9501c50762f6e19cc97
Author: Andy Wingo <address@hidden>
Date: Thu Jun 27 11:26:11 2013 +0200
remove apply:nconc2last
* libguile/eval.c (scm_nconc2last): Remove, now unused.
* doc/ref/api-evaluation.texi (Fly Evaluation): Remove docs.
commit 39caffe79b3d159590b5ce1ccf8fe28c3d5cfdc6
Author: Andy Wingo <address@hidden>
Date: Thu Jun 27 11:25:34 2013 +0200
remove @apply memoizer
* libguile/memoize.c (memoize): Recognize a primcall to 'apply as
SCM_M_APPLY.
(@apply): Remove @apply memoizer.
(unmemoize): Unmemoize using "apply", not "@apply".
* libguile/memoize.h:
* libguile/expand.c (scm_sym_atapply): Remove.
* module/ice-9/boot-9.scm (apply): Re-implement using apply primcall.
Use case-lambda, so as to give an appropriate minimum arity.
* module/language/tree-il/compile-glil.scm (flatten-lambda-case):
Compile a primcall of "apply" specially, not "@apply".
* module/language/tree-il/peval.scm (peval): Match primcalls to "apply",
not "@apply". Residualize "apply" primcalls.
* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
(*multiply-valued-primitives*): Remove @apply, and apply primitive
expander.
* test-suite/tests/peval.test:
* test-suite/tests/tree-il.test: Update tests to expect residualized
"apply".
* test-suite/tests/procprop.test ("procedure-arity"): Update test for
better apply arity.
* test-suite/tests/strings.test ("string"): Update expected error.
commit 1773bc7dd5f4c8a1d13c7cf2015f3a04c9299eeb
Author: Andy Wingo <address@hidden>
Date: Tue Jun 25 22:36:08 2013 +0200
Remove @prompt memoizer
* libguile/memoize.h:
* libguile/memoize.c (MAKMEMO_CALL_WITH_PROMPT, memoize, unmemoize):
Remove the @prompt memoizer in favor of recognizing call-with-prompt
primcalls. Rename SCM_M_PROMPT to SCM_M_CALL_WITH_PROMPT, and pass a
thunk instead of an expression so that it has normal applicative
order.
* libguile/expand.c (PRIMITIVE_REF, PRIMCALL, expand): Produce primcalls
from forms whose car is a primitive.
(expand_atat): Recognize (@@ primitive FOO) as being a primitive-ref.
* module/ice-9/boot-9.scm (call-with-prompt): Instead of dispatching to
the wonky @prompt memoizer, residualize a primcall to
call-with-prompt. The memoizer will DTRT to allow call-with-prompt to
be interpreted correctly without needing an additional binding.
* module/ice-9/eval.scm (primitive-eval): Change the 'prompt clause to a
call to call-with-prompt.
* module/language/tree-il/primitives.scm: No more need to recognize
@prompt.
* libguile/eval.c (eval): Adapt to SCM_M_PROMPT renaming to
SCM_M_CALL_WITH_PROMPT, and apply the thunk.
* libguile/throw.c (pre_init_throw): Adapt to scm_abort_to_prompt_star
rename.
commit 385049949aa52b8578334d073b2c63291a5d5274
Author: Andy Wingo <address@hidden>
Date: Tue Jun 25 21:53:52 2013 +0200
abort-to-prompt* instead of @abort
* libguile/control.h:
* libguile/control.c (scm_abort_to_prompt_star): Rename from
scm_at_abort.
* module/ice-9/boot-9.scm (abort-to-prompt): Use abort-to-prompt*.
* module/language/tree-il/primitives.scm: Handle abort-to-prompt*
instead of @abort.
commit 9833864171fa54100e97040a4f1007919ff614ad
Author: Andy Wingo <address@hidden>
Date: Sun Jun 23 21:36:08 2013 +0200
psyntax: ((@@ primitive NAME) ARG ...) in (guile) module is a primcall
* ice-9/psyntax.scm (@@): Recognize new form, (@@ primitive NAME), which
in operator position expands to a primcall. This expansion is only
available for forms in the (guile) module. Added an argument to @@
and @ procedures, the module, for use by expanded syntax objects;
adapted callers.
(analyze-variable): Error when accessing a primitive for value.
(get-global-definition-hook): Primitives are not macros.
(syntax-type): A form with a primitive in the car is a
primitive-call.
(expand-expr): Residualize primitive calls as primcalls.
(syntax-local-binding): Return 'primitive as the type for primitives.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-evaluation.texi | 12 --
doc/ref/compiler.texi | 20 ---
libguile/control.c | 10 +-
libguile/control.h | 4 +-
libguile/eval.c | 59 +-------
libguile/expand.c | 37 +++--
libguile/memoize.c | 215 +++++++++-----------------
libguile/memoize.h | 10 +-
libguile/throw.c | 4 +-
module/ice-9/boot-9.scm | 35 ++++-
module/ice-9/eval.scm | 15 +--
module/ice-9/psyntax-pp.scm | 120 +++++++++------
module/ice-9/psyntax.scm | 72 ++++++---
module/language/scheme/decompile-tree-il.scm | 19 ---
module/language/tree-il.scm | 44 ------
module/language/tree-il/analyze.scm | 18 --
module/language/tree-il/compile-glil.scm | 111 ++-----------
module/language/tree-il/cse.scm | 18 --
module/language/tree-il/debug.scm | 9 -
module/language/tree-il/effects.scm | 24 ++--
module/language/tree-il/peval.scm | 68 +++++----
module/language/tree-il/primitives.scm | 97 ++----------
test-suite/tests/peval.test | 68 +++++----
test-suite/tests/procprop.test | 4 +-
test-suite/tests/strings.test | 10 +-
test-suite/tests/syncase.test | 33 ++++
test-suite/tests/tree-il.test | 12 +-
27 files changed, 429 insertions(+), 719 deletions(-)
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 63b1d60..f0edd11 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -573,18 +573,6 @@ Call @var{proc} with the array of arguments @var{argv}, as
a
@var{nargs}, as a @code{size_t}.
@end deffn
address@hidden {Scheme Procedure} apply:nconc2last lst
address@hidden {C Function} scm_nconc2last (lst)
address@hidden should be a list (@var{arg1} @dots{} @var{argN}
address@hidden), with @var{arglst} being a list. This function returns
-a list comprising @var{arg1} to @var{argN} plus the elements of
address@hidden @var{lst} is modified to form the return. @var{arglst}
-is not modified, though the return does share structure with it.
-
-This operation collects up the arguments from a list which is
address@hidden style parameters.
address@hidden deffn
-
@deffn {Scheme Procedure} primitive-eval exp
@deffnx {C Function} scm_primitive_eval (exp)
Evaluate @var{exp} in the top-level environment specified by
diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi
index 0615ef7..408c108 100644
--- a/doc/ref/compiler.texi
+++ b/doc/ref/compiler.texi
@@ -466,26 +466,6 @@ evaluate to fluids, and @var{vals} a corresponding list of
expressions
to bind to the fluids during the dynamic extent of the evaluation of
@var{body}.
@end deftp
address@hidden {Scheme Variable} <dynref> fluid
address@hidden {External Representation} (dynref @var{fluid})
-A dynamic variable reference. @var{fluid} should be a Tree-IL
-expression evaluating to a fluid.
address@hidden deftp
address@hidden {Scheme Variable} <dynset> fluid exp
address@hidden {External Representation} (dynset @var{fluid} @var{exp})
-A dynamic variable set. @var{fluid}, a Tree-IL expression evaluating
-to a fluid, will be set to the result of evaluating @var{exp}.
address@hidden deftp
address@hidden {Scheme Variable} <dynwind> winder pre body post unwinder
address@hidden {External Representation} (dynwind @var{winder} @var{pre}
@var{body} @var{post} @var{unwinder})
-A @code{dynamic-wind}. @var{winder} and @var{unwinder} should both
-evaluate to thunks. Ensure that the winder and the unwinder are called
-before entering and after leaving @var{body}. Note that @var{body} is
-an expression, without a thunk wrapper. Guile actually inlines the
-bodies of @var{winder} and @var{unwinder} for the case of normal control
-flow, compiling the expressions in @var{pre} and @var{post},
-respectively.
address@hidden deftp
@deftp {Scheme Variable} <prompt> tag body handler
@deftpx {External Representation} (prompt @var{tag} @var{body} @var{handler})
A dynamic prompt. Instates a prompt named @var{tag}, an expression,
diff --git a/libguile/control.c b/libguile/control.c
index 54c1cd3..3f2651c 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2010, 2011, 2012, 2013 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
@@ -223,9 +223,11 @@ scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
abort ();
}
-SCM_DEFINE (scm_at_abort, "@abort", 2, 0, 0, (SCM tag, SCM args),
- "Abort to the nearest prompt with tag @var{tag}.")
-#define FUNC_NAME s_scm_at_abort
+SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0,
+ (SCM tag, SCM args),
+ "Abort to the nearest prompt with tag @var{tag}, yielding the\n"
+ "values in the list, @var{args}.")
+#define FUNC_NAME s_scm_abort_to_prompt_star
{
SCM *argv;
size_t i;
diff --git a/libguile/control.h b/libguile/control.h
index 4709194..db383cf 100644
--- a/libguile/control.h
+++ b/libguile/control.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2010, 2011, 2012, 2013 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
@@ -24,7 +24,7 @@ SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (SCM vm);
SCM_INTERNAL void scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
scm_i_jmp_buf *registers) SCM_NORETURN;
-SCM_INTERNAL SCM scm_at_abort (SCM tag, SCM args) SCM_NORETURN;
+SCM_INTERNAL SCM scm_abort_to_prompt_star (SCM tag, SCM args) SCM_NORETURN;
SCM_INTERNAL void scm_init_control (void);
diff --git a/libguile/eval.c b/libguile/eval.c
index f743ed7..ca0f731 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -265,20 +265,6 @@ eval (SCM x, SCM env)
scm_define (CAR (mx), EVAL1 (CDR (mx), env));
return SCM_UNSPECIFIED;
- case SCM_M_DYNWIND:
- {
- SCM in, out, res;
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
- in = EVAL1 (CAR (mx), env);
- out = EVAL1 (CDDR (mx), env);
- scm_call_0 (in);
- scm_dynstack_push_dynwind (&t->dynstack, in, out);
- res = eval (CADR (mx), env);
- scm_dynstack_pop (&t->dynstack);
- scm_call_0 (out);
- return res;
- }
-
case SCM_M_WITH_FLUIDS:
{
long i, len;
@@ -436,7 +422,7 @@ eval (SCM x, SCM env)
return SCM_UNSPECIFIED;
}
- case SCM_M_PROMPT:
+ case SCM_M_CALL_WITH_PROMPT:
{
SCM vm, k, res;
scm_i_jmp_buf registers;
@@ -465,7 +451,7 @@ eval (SCM x, SCM env)
goto apply_proc;
}
- res = eval (CADR (mx), env);
+ res = scm_call_0 (eval (CADR (mx), env));
scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
return res;
}
@@ -607,47 +593,6 @@ scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM
args)
SCM_EOL);
}
-/* This code processes the arguments to apply:
-
- (apply PROC ARG1 ... ARGS)
-
- Given a list (ARG1 ... ARGS), this function conses the ARG1
- ... arguments onto the front of ARGS, and returns the resulting
- list. Note that ARGS is a list; thus, the argument to this
- function is a list whose last element is a list.
-
- Apply calls this function, and applies PROC to the elements of the
- result. apply:nconc2last takes care of building the list of
- arguments, given (ARG1 ... ARGS).
-
- Rather than do new consing, apply:nconc2last destroys its argument.
- On that topic, this code came into my care with the following
- beautifully cryptic comment on that topic: "This will only screw
- you if you do (scm_apply scm_apply '( ... ))" If you know what
- they're referring to, send me a patch to this comment. */
-
-SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
- (SCM lst),
- "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
- "conses the @var{arg1} @dots{} arguments onto the front of\n"
- "@var{args}, and returns the resulting list. Note that\n"
- "@var{args} is a list; thus, the argument to this function is\n"
- "a list whose last element is a list.\n"
- "Note: Rather than do new consing, @code{apply:nconc2last}\n"
- "destroys its argument, so use with care.")
-#define FUNC_NAME s_scm_nconc2last
-{
- SCM *lloc;
- SCM_VALIDATE_NONEMPTYLIST (1, lst);
- lloc = &lst;
- while (!scm_is_null (SCM_CDR (*lloc)))
- lloc = SCM_CDRLOC (*lloc);
- SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
- *lloc = SCM_CAR (*lloc);
- return lst;
-}
-#undef FUNC_NAME
-
SCM
scm_map (SCM proc, SCM arg1, SCM args)
diff --git a/libguile/expand.c b/libguile/expand.c
index cb32e37..e5341b7 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -1,4 +1,4 @@
-/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012
+/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -56,8 +56,8 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
SCM_MAKE_EXPANDED_VOID(src)
#define CONST_(src, exp) \
SCM_MAKE_EXPANDED_CONST(src, exp)
-#define PRIMITIVE_REF_TYPE(src, name) \
- SCM_MAKE_EXPANDED_PRIMITIVE_REF_TYPE(src, name)
+#define PRIMITIVE_REF(src, name) \
+ SCM_MAKE_EXPANDED_PRIMITIVE_REF(src, name)
#define LEXICAL_REF(src, name, gensym) \
SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym)
#define LEXICAL_SET(src, name, gensym, exp) \
@@ -74,6 +74,8 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp)
#define CONDITIONAL(src, test, consequent, alternate) \
SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
+#define PRIMCALL(src, name, exps) \
+ SCM_MAKE_EXPANDED_PRIMCALL(src, name, exps)
#define CALL(src, proc, exps) \
SCM_MAKE_EXPANDED_CALL(src, proc, exps)
#define SEQ(src, head, tail) \
@@ -178,14 +180,10 @@ SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply");
SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
SCM_GLOBAL_SYMBOL (scm_sym_at, "@");
SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@");
-SCM_GLOBAL_SYMBOL (scm_sym_at_call_with_values, "@call-with-values");
-SCM_GLOBAL_SYMBOL (scm_sym_atapply, "@apply");
-SCM_GLOBAL_SYMBOL (scm_sym_atcall_cc, "@call-with-current-continuation");
SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
-SCM_GLOBAL_SYMBOL (scm_sym_at_dynamic_wind, "@dynamic-wind");
SCM_GLOBAL_SYMBOL (scm_sym_with_fluids, "with-fluids");
SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
@@ -195,12 +193,13 @@ SCM_GLOBAL_SYMBOL (scm_sym_let, "let");
SCM_GLOBAL_SYMBOL (scm_sym_letrec, "letrec");
SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*");
SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
-SCM_GLOBAL_SYMBOL (scm_sym_at_prompt, "@prompt");
+SCM_SYMBOL (sym_call_with_prompt, "call-with-prompt");
SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
SCM_SYMBOL (sym_lambda_star, "lambda*");
SCM_SYMBOL (sym_eval, "eval");
SCM_SYMBOL (sym_load, "load");
+SCM_SYMBOL (sym_primitive, "primitive");
SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
@@ -356,17 +355,22 @@ expand (SCM exp, SCM env)
{
SCM arg_exps = SCM_EOL;
SCM args = SCM_EOL;
- SCM proc = CAR (exp);
+ SCM proc = expand (CAR (exp), env);
for (arg_exps = CDR (exp); scm_is_pair (arg_exps);
arg_exps = CDR (arg_exps))
args = scm_cons (expand (CAR (arg_exps), env), args);
- if (scm_is_null (arg_exps))
- return CALL (scm_source_properties (exp),
- expand (proc, env),
- scm_reverse_x (args, SCM_UNDEFINED));
- else
+ args = scm_reverse_x (args, SCM_UNDEFINED);
+
+ if (!scm_is_null (arg_exps))
syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
+
+ if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_PRIMITIVE_REF)
+ return PRIMCALL (scm_source_properties (exp),
+ SCM_EXPANDED_REF (proc, PRIMITIVE_REF, NAME),
+ args);
+ else
+ return CALL (scm_source_properties (exp), proc, args);
}
}
else if (scm_is_symbol (exp))
@@ -423,9 +427,12 @@ static SCM
expand_atat (SCM expr, SCM env SCM_UNUSED)
{
ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
+ if (scm_is_eq (CADR (expr), sym_primitive))
+ return PRIMITIVE_REF (scm_source_properties (expr), CADDR (expr));
+
+ ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
return MODULE_REF (scm_source_properties (expr),
CADR (expr), CADDR (expr), SCM_BOOL_F);
}
diff --git a/libguile/memoize.c b/libguile/memoize.c
index f20241c..e2c6bc6 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -60,6 +60,27 @@ SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
+/* Primitives not exposed to general Scheme. */
+static SCM wind;
+static SCM unwind;
+
+static SCM
+do_wind (SCM in, SCM out)
+{
+ scm_dynstack_push_dynwind (&SCM_I_CURRENT_THREAD->dynstack, in, out);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+do_unwind (void)
+{
+ scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
+ return SCM_UNSPECIFIED;
+}
+
+
+
+
/* {Evaluator memoized expressions}
*/
@@ -88,8 +109,6 @@ scm_t_bits scm_tc16_memoized;
MAKMEMO (SCM_M_QUOTE, exp)
#define MAKMEMO_DEFINE(var, val) \
MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
-#define MAKMEMO_DYNWIND(in, expr, out) \
- MAKMEMO (SCM_M_DYNWIND, scm_cons (in, scm_cons (expr, out)))
#define MAKMEMO_WITH_FLUIDS(fluids, vals, expr) \
MAKMEMO (SCM_M_WITH_FLUIDS, scm_cons (fluids, scm_cons (vals, expr)))
#define MAKMEMO_APPLY(proc, args)\
@@ -112,14 +131,9 @@ scm_t_bits scm_tc16_memoized;
MAKMEMO (SCM_M_MODULE_REF, scm_cons (mod, scm_cons (var, public)))
#define MAKMEMO_MOD_SET(val, mod, var, public) \
MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (var,
public))))
-#define MAKMEMO_PROMPT(tag, exp, handler) \
- MAKMEMO (SCM_M_PROMPT, scm_cons (tag, scm_cons (exp, handler)))
-
+#define MAKMEMO_CALL_WITH_PROMPT(tag, thunk, handler) \
+ MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler)))
-/* Primitives for the evaluator */
-scm_t_bits scm_tc16_memoizer;
-#define SCM_MEMOIZER_P(x) (SCM_SMOB_PREDICATE (scm_tc16_memoizer, (x)))
-#define SCM_MEMOIZER(M) (SCM_SMOB_OBJECT_1 (M))
@@ -132,7 +146,6 @@ static const char *const memoized_tags[] =
"let",
"quote",
"define",
- "dynwind",
"with-fluids",
"apply",
"call/cc",
@@ -144,7 +157,7 @@ static const char *const memoized_tags[] =
"toplevel-set!",
"module-ref",
"module-set!",
- "prompt",
+ "call-with-prompt",
};
static int
@@ -250,33 +263,48 @@ memoize (SCM exp, SCM env)
proc = REF (exp, CALL, PROC);
args = memoize_exps (REF (exp, CALL, ARGS), env);
- if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_TOPLEVEL_REF)
- {
- SCM var = scm_module_variable (scm_current_module (),
- REF (proc, TOPLEVEL_REF, NAME));
- if (SCM_VARIABLEP (var))
- {
- SCM val = SCM_VARIABLE_REF (var);
- if (SCM_MEMOIZER_P (val))
- return scm_apply (SCM_SMOB_OBJECT_1 (val), args, SCM_EOL);
- }
- }
- /* otherwise we all fall down here */
return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
}
case SCM_EXPANDED_PRIMCALL:
{
- SCM proc, args;
+ SCM name, args;
+ int nargs;
- if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
- proc = MAKMEMO_TOP_REF (REF (exp, PRIMCALL, NAME));
- else
- proc = MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMCALL, NAME),
- SCM_BOOL_F);
+ name = REF (exp, PRIMCALL, NAME);
args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
-
- return MAKMEMO_CALL (proc, scm_ilength (args), args);
+ nargs = scm_ilength (args);
+
+ if (nargs == 3
+ && scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
+ return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
+ CADR (args),
+ CADDR (args));
+ else if (nargs == 2
+ && scm_is_eq (name, scm_from_latin1_symbol ("apply")))
+ return MAKMEMO_APPLY (CAR (args), CADR (args));
+ else if (nargs == 1
+ && scm_is_eq (name,
+ scm_from_latin1_symbol
+ ("call-with-current-continuation")))
+ return MAKMEMO_CONT (CAR (args));
+ else if (nargs == 2
+ && scm_is_eq (name,
+ scm_from_latin1_symbol ("call-with-values")))
+ return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
+ else if (nargs == 2
+ && scm_is_eq (name, scm_from_latin1_symbol ("wind")))
+ return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args);
+ else if (nargs == 0
+ && scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
+ return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL);
+ else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
+ return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
+ else
+ return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name,
+ SCM_BOOL_F),
+ nargs,
+ args);
}
case SCM_EXPANDED_SEQ:
@@ -509,108 +537,6 @@ SCM_DEFINE (scm_memoize_expression, "memoize-expression",
1, 0, 0,
-#define SCM_MAKE_MEMOIZER(STR, MEMOIZER, N) \
- (scm_cell (scm_tc16_memoizer, \
- SCM_UNPACK (scm_c_make_gsubr (STR, N, 0, 0, MEMOIZER))))
-#define SCM_DEFINE_MEMOIZER(STR, MEMOIZER, N) \
-SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_MEMOIZER (STR, MEMOIZER, N)))
-
-#define SCM_MAKE_REST_MEMOIZER(STR, MEMOIZER, N) \
- (scm_cell (scm_tc16_memoizer, \
- SCM_UNPACK ((scm_c_make_gsubr (STR, N, 0, 1, MEMOIZER)))))
-#define SCM_DEFINE_REST_MEMOIZER(STR, MEMOIZER, N) \
-SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_REST_MEMOIZER (STR, MEMOIZER, N)))
-
-static SCM m_apply (SCM proc, SCM arg, SCM rest);
-static SCM m_call_cc (SCM proc);
-static SCM m_call_values (SCM prod, SCM cons);
-static SCM m_dynamic_wind (SCM pre, SCM exp, SCM post);
-static SCM m_prompt (SCM tag, SCM exp, SCM handler);
-
-SCM_DEFINE_REST_MEMOIZER ("@apply", m_apply, 2);
-SCM_DEFINE_MEMOIZER ("@call-with-current-continuation", m_call_cc, 1);
-SCM_DEFINE_MEMOIZER ("@call-with-values", m_call_values, 2);
-SCM_DEFINE_MEMOIZER ("@dynamic-wind", m_dynamic_wind, 3);
-SCM_DEFINE_MEMOIZER ("@prompt", m_prompt, 3);
-
-
-
-
-static SCM m_apply (SCM proc, SCM arg, SCM rest)
-#define FUNC_NAME "@apply"
-{
- long len;
-
- SCM_VALIDATE_MEMOIZED (1, proc);
- SCM_VALIDATE_MEMOIZED (2, arg);
- len = scm_ilength (rest);
- if (len < 0)
- abort ();
- else if (len == 0)
- return MAKMEMO_APPLY (proc, arg);
- else
- {
- SCM tail;
-
- rest = scm_reverse (rest);
- tail = scm_car (rest);
- rest = scm_cdr (rest);
- len--;
-
- while (scm_is_pair (rest))
- {
- tail = MAKMEMO_CALL (MAKMEMO_MOD_REF (scm_list_1
(scm_from_latin1_symbol ("guile")),
- scm_from_latin1_symbol
("cons"),
- SCM_BOOL_F),
- 2,
- scm_list_2 (scm_car (rest), tail));
- rest = scm_cdr (rest);
- }
- return MAKMEMO_APPLY (proc, tail);
- }
-}
-#undef FUNC_NAME
-
-static SCM m_call_cc (SCM proc)
-#define FUNC_NAME "@call-with-current-continuation"
-{
- SCM_VALIDATE_MEMOIZED (1, proc);
- return MAKMEMO_CONT (proc);
-}
-#undef FUNC_NAME
-
-static SCM m_call_values (SCM prod, SCM cons)
-#define FUNC_NAME "@call-with-values"
-{
- SCM_VALIDATE_MEMOIZED (1, prod);
- SCM_VALIDATE_MEMOIZED (2, cons);
- return MAKMEMO_CALL_WITH_VALUES (prod, cons);
-}
-#undef FUNC_NAME
-
-static SCM m_dynamic_wind (SCM in, SCM expr, SCM out)
-#define FUNC_NAME "memoize-dynwind"
-{
- SCM_VALIDATE_MEMOIZED (1, in);
- SCM_VALIDATE_MEMOIZED (2, expr);
- SCM_VALIDATE_MEMOIZED (3, out);
- return MAKMEMO_DYNWIND (in, expr, out);
-}
-#undef FUNC_NAME
-
-static SCM m_prompt (SCM tag, SCM exp, SCM handler)
-#define FUNC_NAME "@prompt"
-{
- SCM_VALIDATE_MEMOIZED (1, tag);
- SCM_VALIDATE_MEMOIZED (2, exp);
- SCM_VALIDATE_MEMOIZED (3, handler);
- return MAKMEMO_PROMPT (tag, exp, handler);
-}
-#undef FUNC_NAME
-
-
-
-
SCM_SYMBOL (sym_placeholder, "_");
static SCM unmemoize (SCM expr);
@@ -669,24 +595,22 @@ unmemoize (const SCM expr)
switch (SCM_MEMOIZED_TAG (expr))
{
case SCM_M_APPLY:
- return scm_cons (scm_sym_atapply, unmemoize_exprs (args));
+ return scm_cons (scm_from_latin1_symbol ("apply"),
+ unmemoize_exprs (args));
case SCM_M_SEQ:
return scm_list_3 (scm_sym_begin, unmemoize (CAR (args)),
unmemoize (CDR (args)));
case SCM_M_CALL:
return scm_cons (unmemoize (CAR (args)), unmemoize_exprs (CDDR (args)));
case SCM_M_CONT:
- return scm_list_2 (scm_sym_atcall_cc, unmemoize (args));
+ return scm_list_2 (scm_from_latin1_symbol
+ ("call-with-current_continuation"),
+ unmemoize (args));
case SCM_M_CALL_WITH_VALUES:
- return scm_list_3 (scm_sym_at_call_with_values,
+ return scm_list_3 (scm_from_latin1_symbol ("call-with-values"),
unmemoize (CAR (args)), unmemoize (CDR (args)));
case SCM_M_DEFINE:
return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (args)));
- case SCM_M_DYNWIND:
- return scm_list_4 (scm_sym_at_dynamic_wind,
- unmemoize (CAR (args)),
- unmemoize (CADR (args)),
- unmemoize (CDDR (args)));
case SCM_M_WITH_FLUIDS:
{
SCM binds = SCM_EOL, fluids, vals;
@@ -768,8 +692,8 @@ unmemoize (const SCM expr)
scm_i_finite_list_copy (CADR (args)),
CADDR (args)),
unmemoize (CAR (args)));
- case SCM_M_PROMPT:
- return scm_list_4 (scm_sym_at_prompt,
+ case SCM_M_CALL_WITH_PROMPT:
+ return scm_list_4 (scm_from_latin1_symbol ("call-with-prompt"),
unmemoize (CAR (args)),
unmemoize (CADR (args)),
unmemoize (CDDR (args)));
@@ -931,10 +855,11 @@ scm_init_memoize ()
scm_tc16_memoized = scm_make_smob_type ("%memoized", 0);
scm_set_smob_print (scm_tc16_memoized, scm_print_memoized);
- scm_tc16_memoizer = scm_make_smob_type ("memoizer", 0);
-
#include "libguile/memoize.x"
+ wind = scm_c_make_gsubr ("wind", 2, 0, 0, do_wind);
+ unwind = scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind);
+
list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
}
diff --git a/libguile/memoize.h b/libguile/memoize.h
index da78b06..ab7e777 100644
--- a/libguile/memoize.h
+++ b/libguile/memoize.h
@@ -3,7 +3,7 @@
#ifndef SCM_MEMOIZE_H
#define SCM_MEMOIZE_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011
+/* Copyright (C)
1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011,2013
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -48,12 +48,7 @@ SCM_API SCM scm_sym_with_fluids;
SCM_API SCM scm_sym_at;
SCM_API SCM scm_sym_atat;
-SCM_API SCM scm_sym_atapply;
-SCM_API SCM scm_sym_atcall_cc;
-SCM_API SCM scm_sym_at_call_with_values;
-SCM_API SCM scm_sym_at_prompt;
SCM_API SCM scm_sym_delay;
-SCM_API SCM scm_sym_at_dynamic_wind;
SCM_API SCM scm_sym_eval_when;
SCM_API SCM scm_sym_arrow;
SCM_API SCM scm_sym_else;
@@ -78,7 +73,6 @@ enum
SCM_M_LET,
SCM_M_QUOTE,
SCM_M_DEFINE,
- SCM_M_DYNWIND,
SCM_M_WITH_FLUIDS,
SCM_M_APPLY,
SCM_M_CONT,
@@ -90,7 +84,7 @@ enum
SCM_M_TOPLEVEL_SET,
SCM_M_MODULE_REF,
SCM_M_MODULE_SET,
- SCM_M_PROMPT
+ SCM_M_CALL_WITH_PROMPT
};
diff --git a/libguile/throw.c b/libguile/throw.c
index ae131d0..de157fa 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009,
2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009,
2010, 2011, 2012, 2013 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
@@ -510,7 +510,7 @@ static SCM
pre_init_throw (SCM k, SCM args)
{
if (find_pre_init_catch ())
- return scm_at_abort (sym_pre_init_catch_tag, scm_cons (k, args));
+ return scm_abort_to_prompt_star (sym_pre_init_catch_tag, scm_cons (k,
args));
else
{
static int error_printing_error = 0;
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index f1fd041..d6c4cfd 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -62,9 +62,9 @@
%default-prompt-tag)))
(define (call-with-prompt tag thunk handler)
- (@prompt tag (thunk) handler))
+ ((@@ primitive call-with-prompt) tag thunk handler))
(define (abort-to-prompt tag . args)
- (@abort tag args))
+ (abort-to-prompt* tag args))
;; Define catch and with-throw-handler, using some common helper routines and a
@@ -192,7 +192,7 @@ If there is no handler at all, Guile prints an error and
then exits."
;;;
;; These are are the procedural wrappers around the primitives of
-;; Guile's language: @apply, @call-with-current-continuation, etc.
+;; Guile's language: apply, call-with-current-continuation, etc.
;;
;; Usually, a call to a primitive is compiled specially. The compiler
;; knows about all these kinds of expressions. But the primitives may
@@ -200,12 +200,22 @@ If there is no handler at all, Guile prints an error and
then exits."
;; stub procedures are the "values" of apply, dynamic-wind, and other
;; such primitives.
;;
-(define (apply fun . args)
- (@apply fun (apply:nconc2last args)))
+(define apply
+ (case-lambda
+ ((fun args)
+ ((@@ primitive apply) fun args))
+ ((fun arg1 . args)
+ (letrec ((append* (lambda (tail)
+ (let ((tail (car tail))
+ (tail* (cdr tail)))
+ (if (null? tail*)
+ tail
+ (cons tail (append* tail*)))))))
+ (apply fun (cons arg1 (append* args)))))))
(define (call-with-current-continuation proc)
- (@call-with-current-continuation proc))
+ ((@@ primitive call-with-current-continuation) proc))
(define (call-with-values producer consumer)
- (@call-with-values producer consumer))
+ ((@@ primitive call-with-values) producer consumer))
(define (dynamic-wind in thunk out)
"All three arguments must be 0-argument procedures.
Guard @var{in} is called, then @var{thunk}, then
@@ -256,7 +266,16 @@ x
a-cont
@result{} special-binding
@end lisp"
- (@dynamic-wind in (thunk) out))
+ (if (thunk? out)
+ (in)
+ (scm-error 'wrong-type-arg "dynamic-wind" "Not a thunk: ~S"
+ (list out) #f))
+ ((@@ primitive wind) in out)
+ (call-with-values thunk
+ (lambda vals
+ ((@@ primitive unwind))
+ (out)
+ (apply values vals))))
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 90bc254..0e6aeac 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -203,7 +203,6 @@
;;; module-ref: 14468
;;; define: 1259
;;; toplevel-set: 328
-;;; dynwind: 162
;;; with-fluids: 0
;;; call/cc: 0
;;; module-set: 0
@@ -463,11 +462,6 @@
env))))
(eval x env)))
- (('dynwind (in exp . out))
- (dynamic-wind (eval in env)
- (lambda () (eval exp env))
- (eval out env)))
-
(('with-fluids (fluids vals . exp))
(let* ((fluids (map (lambda (x) (eval x env)) fluids))
(vals (map (lambda (x) (eval x env)) vals)))
@@ -477,10 +471,11 @@
(with-fluids (((car fluids) (car vals)))
(lp (cdr fluids) (cdr vals)))))))
- (('prompt (tag exp . handler))
- (@prompt (eval tag env)
- (eval exp env)
- (eval handler env)))
+ (('call-with-prompt (tag thunk . handler))
+ (call-with-prompt
+ (eval tag env)
+ (eval thunk env)
+ (eval handler env)))
(('call/cc proc)
(call/cc (eval proc env)))
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 4476f50..fe16ae4 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -124,15 +124,16 @@
(lambda (symbol module)
(if (and (not module) (current-module))
(warn "module system is booted, we should have a module" symbol))
- (let ((v (module-variable
- (if module (resolve-module (cdr module)) (current-module))
- symbol)))
- (and v
- (variable-bound? v)
- (let ((val (variable-ref v)))
- (and (macro? val)
- (macro-type val)
- (cons (macro-type val) (macro-binding val))))))))
+ (and (not (equal? module '(primitive)))
+ (let ((v (module-variable
+ (if module (resolve-module (cdr module))
(current-module))
+ symbol)))
+ (and v
+ (variable-bound? v)
+ (let ((val (variable-ref v)))
+ (and (macro? val)
+ (macro-type val)
+ (cons (macro-type val) (macro-binding val)))))))))
(decorate-source
(lambda (e s)
(if (and s (supports-source-properties? e))
@@ -177,6 +178,8 @@
(module-variable (resolve-module mod) var))
(modref-cont mod var #f)
(bare-cont var)))
+ ((memv key '(primitive))
+ (syntax-violation #f "primitive not in operator position"
var))
(else (syntax-violation #f "bad module kind" var mod))))))))
(build-global-reference
(lambda (source var mod)
@@ -736,7 +739,9 @@
(let ((key ftype))
(cond ((memv key '(lexical)) (values 'lexical-call fval
e e w s mod))
((memv key '(global))
- (values 'global-call (make-syntax-object fval w
fmod) e e w s mod))
+ (if (equal? fmod '(primitive))
+ (values 'primitive-call fval e e w s mod)
+ (values 'global-call (make-syntax-object fval w
fmod) e e w s mod)))
((memv key '(macro))
(syntax-type
(expand-macro fval e r w s rib mod)
@@ -748,7 +753,7 @@
for-car?))
((memv key '(module-ref))
(call-with-values
- (lambda () (fval e r w))
+ (lambda () (fval e r w mod))
(lambda (e r w s mod) (syntax-type e r w s rib
mod for-car?))))
((memv key '(core)) (values 'core-form fval e e w
s mod))
((memv key '(local-syntax))
@@ -838,7 +843,7 @@
((memv key '(core core-form)) (value e r w s mod))
((memv key '(module-ref))
(call-with-values
- (lambda () (value e r w))
+ (lambda () (value e r w mod))
(lambda (e r w s mod) (expand e r w mod))))
((memv key '(lexical-call))
(expand-call
@@ -864,6 +869,16 @@
w
s
mod))
+ ((memv key '(primitive-call))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
+ (if tmp
+ (apply (lambda (e)
+ (build-primcall s value (map (lambda (e) (expand
e r w mod)) e)))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))
((memv key '(constant))
(build-data s (strip (source-wrap e w s mod) '(()))))
((memv key '(global)) (build-global-reference s value mod))
@@ -1959,7 +1974,7 @@
(if (memv key '(module-ref))
(let ((val (expand val r w mod)))
(call-with-values
- (lambda () (value (cons head tail) r w))
+ (lambda () (value (cons head tail) r w mod))
(lambda (e r w s* mod)
(let* ((tmp-1 e) (tmp (list tmp-1)))
(if (and tmp (apply (lambda (e) (id?
e)) tmp))
@@ -1982,7 +1997,7 @@
(global-extend
'module-ref
'@
- (lambda (e r w)
+ (lambda (e r w mod)
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
(if (and tmp
(apply (lambda (mod id) (and (and-map id? mod) (id? id)))
tmp))
@@ -2002,7 +2017,7 @@
(global-extend
'module-ref
'@@
- (lambda (e r w)
+ (lambda (e r w mod)
(letrec*
((remodulate
(lambda (x mod)
@@ -2021,33 +2036,46 @@
(vector-set! v i (remodulate (vector-ref x i) mod))
(loop (+ i 1)))))))
(else x)))))
- (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
- (if (and tmp
- (apply (lambda (mod id) (and (and-map id? mod) (id? id)))
tmp))
- (apply (lambda (mod id)
- (values
- (syntax->datum id)
- r
- '((top))
- #f
- (syntax->datum
- (cons '#(syntax-object private ((top)) (hygiene
guile)) mod))))
- tmp)
- (let ((tmp ($sc-dispatch
- tmp-1
- '(_ #(free-id #(syntax-object @@ ((top)) (hygiene
guile)))
- each-any
- any))))
- (if (and tmp (apply (lambda (mod exp) (and-map id? mod)) tmp))
- (apply (lambda (mod exp)
- (let ((mod (syntax->datum
- (cons '#(syntax-object private ((top))
(hygiene guile)) mod))))
- (values (remodulate exp mod) r w (source-annotation
exp) mod)))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1))))))))
+ (let* ((tmp e)
+ (tmp-1 ($sc-dispatch
+ tmp
+ '(_ #(free-id #(syntax-object primitive ((top))
(hygiene guile))) any))))
+ (if (and tmp-1
+ (apply (lambda (id)
+ (and (id? id)
+ (equal?
+ (cdr (if (syntax-object? id)
(syntax-object-module id) mod))
+ '(guile))))
+ tmp-1))
+ (apply (lambda (id) (values (syntax->datum id) r '((top)) #f
'(primitive)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any))))
+ (if (and tmp-1
+ (apply (lambda (mod id) (and (and-map id? mod) (id?
id))) tmp-1))
+ (apply (lambda (mod id)
+ (values
+ (syntax->datum id)
+ r
+ '((top))
+ #f
+ (syntax->datum
+ (cons '#(syntax-object private ((top)) (hygiene
guile)) mod))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch
+ tmp
+ '(_ #(free-id #(syntax-object @@ ((top))
(hygiene guile)))
+ each-any
+ any))))
+ (if (and tmp-1 (apply (lambda (mod exp) (and-map id? mod))
tmp-1))
+ (apply (lambda (mod exp)
+ (let ((mod (syntax->datum
+ (cons '#(syntax-object private
((top)) (hygiene guile)) mod))))
+ (values (remodulate exp mod) r w
(source-annotation exp) mod)))
+ tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp))))))))))
(global-extend
'core
'if
@@ -2359,7 +2387,8 @@
(let ((x id))
(if (not (nonsymbol-id? x))
(syntax-violation 'syntax-module "invalid argument" x)))
- (cdr (syntax-object-module id))))
+ (let ((mod (syntax-object-module id)))
+ (and (not (equal? mod '(primitive))) (cdr mod)))))
(syntax-local-binding
(lambda* (id
#:key
@@ -2392,7 +2421,10 @@
(values 'syntax-parameter (car value)))
((memv key '(syntax)) (values 'pattern-variable
value))
((memv key '(displaced-lexical)) (values
'displaced-lexical #f))
- ((memv key '(global)) (values 'global (cons value
(cdr mod))))
+ ((memv key '(global))
+ (if (equal? mod '(primitive))
+ (values 'primitive value)
+ (values 'global (cons value (cdr mod)))))
(else (values 'other #f)))))))))))
(syntax-locally-bound-identifiers
(lambda (id)
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 0176adb..515bef3 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -289,15 +289,16 @@
(lambda (symbol module)
(if (and (not module) (current-module))
(warn "module system is booted, we should have a module" symbol))
- (let ((v (module-variable (if module
- (resolve-module (cdr module))
- (current-module))
- symbol)))
- (and v (variable-bound? v)
- (let ((val (variable-ref v)))
- (and (macro? val) (macro-type val)
- (cons (macro-type val)
- (macro-binding val)))))))))
+ (and (not (equal? module '(primitive)))
+ (let ((v (module-variable (if module
+ (resolve-module (cdr module))
+ (current-module))
+ symbol)))
+ (and v (variable-bound? v)
+ (let ((val (variable-ref v)))
+ (and (macro? val) (macro-type val)
+ (cons (macro-type val)
+ (macro-binding val))))))))))
(define (decorate-source e s)
@@ -352,6 +353,8 @@
(module-variable (resolve-module mod) var))
(modref-cont mod var #f)
(bare-cont var)))
+ ((primitive)
+ (syntax-violation #f "primitive not in operator position" var))
(else (syntax-violation #f "bad module kind" var mod))))))
(define build-global-reference
@@ -1222,6 +1225,7 @@
;; displaced-lexical none displaced lexical identifier
;; lexical-call name call to lexical variable
;; global-call name call to global variable
+ ;; primitive-call name call to primitive
;; call none any other call
;; begin-form none begin expression
;; define-form id variable definition
@@ -1268,16 +1272,19 @@
((lexical)
(values 'lexical-call fval e e w s mod))
((global)
- ;; If we got here via an (@@ ...) expansion, we need to
- ;; make sure the fmod information is propagated back
- ;; correctly -- hence this consing.
- (values 'global-call (make-syntax-object fval w fmod)
- e e w s mod))
+ (if (equal? fmod '(primitive))
+ (values 'primitive-call fval e e w s mod)
+ ;; If we got here via an (@@ ...) expansion, we
+ ;; need to make sure the fmod information is
+ ;; propagated back correctly -- hence this
+ ;; consing.
+ (values 'global-call (make-syntax-object fval w fmod)
+ e e w s mod)))
((macro)
(syntax-type (expand-macro fval e r w s rib mod)
r empty-wrap s rib mod for-car?))
((module-ref)
- (call-with-values (lambda () (fval e r w))
+ (call-with-values (lambda () (fval e r w mod))
(lambda (e r w s mod)
(syntax-type e r w s rib mod for-car?))))
((core)
@@ -1346,7 +1353,7 @@
;; apply transformer
(value e r w s mod))
((module-ref)
- (call-with-values (lambda () (value e r w))
+ (call-with-values (lambda () (value e r w mod))
(lambda (e r w s mod)
(expand e r w mod))))
((lexical-call)
@@ -1368,6 +1375,13 @@
(syntax-object-module value)
mod))
e r w s mod))
+ ((primitive-call)
+ (syntax-case e ()
+ ((_ e ...)
+ (build-primcall s
+ value
+ (map (lambda (e) (expand e r w mod))
+ #'(e ...))))))
((constant) (build-data s (strip (source-wrap e w s mod)
empty-wrap)))
((global) (build-global-reference s value mod))
((call) (expand-call (expand (car e) r w mod) e r w s mod))
@@ -2321,7 +2335,7 @@
(case type
((module-ref)
(let ((val (expand #'val r w mod)))
- (call-with-values (lambda () (value #'(head tail ...) r w))
+ (call-with-values (lambda () (value #'(head tail ...) r w
mod))
(lambda (e r w s* mod)
(syntax-case e ()
(e (id? #'e)
@@ -2335,7 +2349,7 @@
(_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
(global-extend 'module-ref '@
- (lambda (e r w)
+ (lambda (e r w mod)
(syntax-case e ()
((_ (mod ...) id)
(and (and-map id? #'(mod ...)) (id? #'id))
@@ -2346,7 +2360,7 @@
#'(public mod ...)))))))
(global-extend 'module-ref '@@
- (lambda (e r w)
+ (lambda (e r w mod)
(define remodulate
(lambda (x mod)
(cond ((pair? x)
@@ -2364,7 +2378,16 @@
((fx= i n) v)
(vector-set! v i (remodulate (vector-ref x
i) mod)))))
(else x))))
- (syntax-case e (@@)
+ (syntax-case e (@@ primitive)
+ ((_ primitive id)
+ (and (id? #'id)
+ (equal? (cdr (if (syntax-object? #'id)
+ (syntax-object-module #'id)
+ mod))
+ '(guile)))
+ ;; Strip the wrap from the identifier and return
top-wrap
+ ;; so that the identifier will not be captured by
lexicals.
+ (values (syntax->datum #'id) r top-wrap #f
'(primitive)))
((_ (mod ...) id)
(and (and-map id? #'(mod ...)) (id? #'id))
;; Strip the wrap from the identifier and return
top-wrap
@@ -2660,7 +2683,9 @@
(let ()
(define (syntax-module id)
(arg-check nonsymbol-id? id 'syntax-module)
- (cdr (syntax-object-module id)))
+ (let ((mod (syntax-object-module id)))
+ (and (not (equal? mod '(primitive)))
+ (cdr mod))))
(define* (syntax-local-binding id #:key (resolve-syntax-parameters? #t))
(arg-check nonsymbol-id? id 'syntax-local-binding)
@@ -2687,7 +2712,10 @@
((syntax-parameter) (values 'syntax-parameter (car value)))
((syntax) (values 'pattern-variable value))
((displaced-lexical) (values 'displaced-lexical #f))
- ((global) (values 'global (cons value (cdr mod))))
+ ((global)
+ (if (equal? mod '(primitive))
+ (values 'primitive value)
+ (values 'global (cons value (cdr mod)))))
(else (values 'other #f))))))))
(define (syntax-locally-bound-identifiers id)
diff --git a/module/language/scheme/decompile-tree-il.scm
b/module/language/scheme/decompile-tree-il.scm
index c065474..7dc55bf 100644
--- a/module/language/scheme/decompile-tree-il.scm
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -432,23 +432,12 @@
`(call-with-values (lambda () ,@(recurse-body exp))
,(recurse (make-lambda #f '() body))))
- ((<dynwind> body winder unwinder)
- `(dynamic-wind ,(recurse winder)
- (lambda () ,@(recurse-body body))
- ,(recurse unwinder)))
-
((<dynlet> fluids vals body)
`(with-fluids ,(map list
(map recurse fluids)
(map recurse vals))
,@(recurse-body body)))
- ((<dynref> fluid)
- `(fluid-ref ,(recurse fluid)))
-
- ((<dynset> fluid exp)
- `(fluid-set! ,(recurse fluid) ,(recurse exp)))
-
((<prompt> tag body handler)
`(call-with-prompt
,(recurse tag)
@@ -761,20 +750,12 @@
(primitive 'call-with-values)
(recurse exp) (recurse body))
- ((<dynwind> winder body unwinder)
- (primitive 'dynamic-wind)
- (recurse winder) (recurse body) (recurse unwinder))
-
((<dynlet> fluids vals body)
(primitive 'with-fluids)
(for-each recurse fluids)
(for-each recurse vals)
(recurse body))
- ((<dynref> fluid) (primitive 'fluid-ref) (recurse fluid))
- ((<dynset> fluid exp)
- (primitive 'fluid-set!) (recurse fluid) (recurse exp))
-
((<prompt> tag body handler)
(primitive 'call-with-prompt)
(primitive 'lambda)
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index b800912..1580142 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -46,10 +46,7 @@
<letrec> letrec? make-letrec letrec-src letrec-in-order?
letrec-names letrec-gensyms letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
<let-values> let-values? make-let-values let-values-src
let-values-exp let-values-body
- <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder
dynwind-body dynwind-unwinder
<dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals
dynlet-body
- <dynref> dynref? make-dynref dynref-src dynref-fluid
- <dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
<prompt> prompt? make-prompt prompt-src prompt-tag prompt-body
prompt-handler
<abort> abort? make-abort abort-src abort-tag abort-args abort-tail
@@ -136,9 +133,6 @@
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
(<fix> names gensyms vals body)
(<let-values> exp body)
- (<dynwind> winder body unwinder)
- (<dynref> fluid)
- (<dynset> fluid exp)
(<prompt> tag body handler)
(<abort> tag args tail))
@@ -249,18 +243,9 @@
(('let-values exp body)
(make-let-values loc (retrans exp) (retrans body)))
- (('dynwind winder body unwinder)
- (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
-
(('dynlet fluids vals body)
(make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
- (('dynref fluid)
- (make-dynref loc (retrans fluid)))
-
- (('dynset fluid exp)
- (make-dynset loc (retrans fluid) (retrans exp)))
-
(('prompt tag body handler)
(make-prompt loc (retrans tag) (retrans body) (retrans handler)))
@@ -339,21 +324,10 @@
(($ <let-values> src exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
- (($ <dynwind> src winder body unwinder)
- `(dynwind ,(unparse-tree-il winder)
- ,(unparse-tree-il body)
- ,(unparse-tree-il unwinder)))
-
(($ <dynlet> src fluids vals body)
`(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
,(unparse-tree-il body)))
- (($ <dynref> src fluid)
- `(dynref ,(unparse-tree-il fluid)))
-
- (($ <dynset> src fluid exp)
- `(dynset ,(unparse-tree-il fluid) ,(unparse-tree-il exp)))
-
(($ <prompt> src tag body handler)
`(prompt ,(unparse-tree-il tag)
,(unparse-tree-il body)
@@ -424,19 +398,10 @@
(($ <let-values> src exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
- (($ <dynwind> src winder body unwinder)
- (let*-values (((seed ...) (foldts winder seed ...))
- ((seed ...) (foldts unwinder seed ...)))
- (foldts body seed ...)))
(($ <dynlet> src fluids vals body)
(let*-values (((seed ...) (fold-values foldts fluids seed ...))
((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
- (($ <dynref> src fluid)
- (foldts fluid seed ...))
- (($ <dynset> src fluid exp)
- (let*-values (((seed ...) (foldts fluid seed ...)))
- (foldts exp seed ...)))
(($ <prompt> src tag body handler)
(let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (foldts body seed ...)))
@@ -527,18 +492,9 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(($ <let-values> src exp body)
(make-let-values src (lp exp) (lp body)))
- (($ <dynwind> src winder body unwinder)
- (make-dynwind src (lp winder) (lp body) (lp unwinder)))
-
(($ <dynlet> src fluids vals body)
(make-dynlet src (map lp fluids) (map lp vals) (lp body)))
- (($ <dynref> src fluid)
- (make-dynref src (lp fluid)))
-
- (($ <dynset> src fluid exp)
- (make-dynset src (lp fluid) (lp exp)))
-
(($ <prompt> src tag body handler)
(make-prompt src (lp tag) (lp body) (lp handler)))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index 84a044c..673f68b 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -337,18 +337,9 @@
((<let-values> exp body)
(lset-union eq? (step exp) (step body)))
- ((<dynwind> winder body unwinder)
- (lset-union eq? (step winder) (step body) (step unwinder)))
-
((<dynlet> fluids vals body)
(apply lset-union eq? (step body) (map step (append fluids vals))))
- ((<dynref> fluid)
- (step fluid))
-
- ((<dynset> fluid exp)
- (lset-union eq? (step fluid) (step exp)))
-
((<prompt> tag body handler)
(lset-union eq? (step tag) (step body) (step-tail handler)))
@@ -511,18 +502,9 @@
((<let-values> exp body)
(max (recur exp) (recur body)))
- ((<dynwind> winder body unwinder)
- (max (recur winder) (recur body) (recur unwinder)))
-
((<dynlet> fluids vals body)
(apply max (recur body) (map recur (append fluids vals))))
- ((<dynref> fluid)
- (recur fluid))
-
- ((<dynset> fluid exp)
- (max (recur fluid) (recur exp)))
-
((<prompt> tag body handler)
(let ((cont-var (and (lambda-case? handler)
(pair? (lambda-case-gensyms handler))
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index c06a1f6..c2dba52 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -114,6 +114,8 @@
(list . list)
(vector . vector)
((class-of . 1) . class-of)
+ ((fluid-ref . 1) . fluid-ref)
+ ((fluid-set! . 2) . fluid-set)
((@slot-ref . 2) . slot-ref)
((@slot-set! . 3) . slot-set)
((string-length . 1) . string-length)
@@ -135,6 +137,9 @@
;; hack for lua
(return/values . return/values)
+ ((wind . 2) . wind)
+ ((unwind . 0) . unwind)
+
((bytevector-u8-ref . 2) . bv-u8-ref)
((bytevector-u8-set! . 3) . bv-u8-set)
((bytevector-s8-ref . 2) . bv-s8-ref)
@@ -372,7 +377,7 @@
((<primcall> src name args)
(pmatch (cons name args)
- ((@apply ,proc . ,args)
+ ((apply ,proc . ,args)
(cond
((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
(not (eq? context 'push)) (not (eq? context 'vals)))
@@ -398,7 +403,8 @@
(emit-code src (make-glil-call 'apply (1+ (length args))))
(maybe-emit-return))
(else
- (comp-tail (make-primcall src 'apply (cons proc args))))))))
+ (comp-tail (make-call src (make-primitive-ref #f 'apply)
+ (cons proc args))))))))
((values . _)
;; tail: (lambda () (values '(1 2)))
@@ -431,7 +437,7 @@
(make-glil-call 'return 1)
(make-glil-call 'return/values len)))))))
- ((@call-with-values ,producer ,consumer)
+ ((call-with-values ,producer ,consumer)
;; CONSUMER
;; PRODUCER
;; (mv-call MV)
@@ -442,7 +448,8 @@
(case context
((vals)
;; Fall back.
- (comp-tail (make-primcall src 'call-with-values args)))
+ (comp-tail
+ (make-call src (make-toplevel-ref #f 'call-with-values) args)))
(else
(let ((MV (make-label)) (POST (make-label)))
(if (not (eq? context 'tail))
@@ -464,14 +471,16 @@
(emit-code #f (make-glil-call 'drop 1)))
(maybe-emit-return)))))))
- ((@call-with-current-continuation ,proc)
+ ((call-with-current-continuation ,proc)
(case context
((tail)
(comp-push proc)
(emit-code src (make-glil-call 'tail-call/cc 1)))
((vals)
(comp-vals
- (make-primcall src 'call-with-current-continuation args)
+ (make-call src
+ (make-primitive-ref #f
'call-with-current-continuation)
+ args)
MVRA)
(maybe-emit-return))
((push)
@@ -481,7 +490,9 @@
((drop)
;; Fall back.
(comp-tail
- (make-primcall src 'call-with-current-continuation args)))))
+ (make-call src
+ (make-primitive-ref #f
'call-with-current-continuation)
+ args)))))
;; A hack for variable-set, the opcode for which takes its args
;; reversed, relative to the variable-set! function
@@ -934,74 +945,6 @@
(clear-stack-slots context gensyms)
(emit-code #f (make-glil-unbind))))))
- ((<dynwind> src winder body unwinder)
- (define (thunk? x)
- (and (lambda? x)
- (null? (lambda-case-gensyms (lambda-body x)))))
- (define (make-wrong-type-arg x)
- (make-primcall src 'scm-error
- (list
- (make-const #f 'wrong-type-arg)
- (make-const #f "dynamic-wind")
- (make-const #f "Wrong type (expecting thunk): ~S")
- (make-primcall #f 'list (list x))
- (make-primcall #f 'list (list x)))))
- (define (emit-thunk-check x)
- (comp-drop (make-conditional
- src
- (make-primcall src 'thunk? (list x))
- (make-void #f)
- (make-wrong-type-arg x))))
-
- ;; The `winder' and `unwinder' of a dynwind are constant
- ;; expressions and can be duplicated.
- (if (not (thunk? winder))
- (emit-thunk-check winder))
- (comp-push winder)
- (if (not (thunk? unwinder))
- (emit-thunk-check unwinder))
- (comp-push unwinder)
- (emit-code #f (make-glil-call 'wind 2))
-
- (case context
- ((tail)
- (let ((MV (make-label)))
- (comp-vals body MV)
- ;; One value. Unwind and return the value.
- (emit-code #f (make-glil-call 'unwind 0))
- (emit-code #f (make-glil-call 'return 1))
-
- (emit-label MV)
- ;; Multiple values. Unwind and return the values.
- (emit-code #f (make-glil-call 'unwind 0))
- (emit-code #f (make-glil-call 'return/nvalues 1))))
-
- ((push)
- ;; We only want one value, so ask for one value and then
- ;; unwind, leaving the value on the stack.
- (comp-push body)
- (emit-code #f (make-glil-call 'unwind 0)))
-
- ((vals)
- (let ((MV (make-label)))
- (comp-vals body MV)
- ;; Transform a singly-valued return to a multiple-value
- ;; return and fall through to MV case.
- (emit-code #f (make-glil-const 1))
-
- (emit-label MV)
- ;; Multiple values: unwind and go to the MVRA.
- (emit-code #f (make-glil-call 'unwind 0))
- (emit-branch #f 'br MVRA)))
-
- ((drop)
- ;; Compile body, discarding values. Then unwind and fall
- ;; through, or goto RA if there is one.
- (comp-drop body)
- (emit-code #f (make-glil-call 'unwind 0))
- (if RA
- (emit-branch #f 'br RA)))))
-
((<dynlet> src fluids vals body)
(for-each comp-push fluids)
(for-each comp-push vals)
@@ -1048,24 +991,6 @@
(if RA
(emit-branch #f 'br RA)))))
- ((<dynref> src fluid)
- (case context
- ((drop)
- (comp-drop fluid))
- ((push vals tail)
- (comp-push fluid)
- (emit-code #f (make-glil-call 'fluid-ref 1))))
- (maybe-emit-return))
-
- ((<dynset> src fluid exp)
- (comp-push fluid)
- (comp-push exp)
- (emit-code #f (make-glil-call 'fluid-set 2))
- (case context
- ((push vals tail)
- (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
;; What's the deal here? The deal is that we are compiling the start of a
;; delimited continuation. We try to avoid heap allocation in the normal
;; case; so the body is an expression, not a thunk, and we try to render
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index 4c50114..ffddc19 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -442,15 +442,6 @@
((consumer db**) (visit consumer (concat db* db) env
ctx)))
(return (make-let-values src producer consumer)
(concat db** db*))))
- (($ <dynwind> src winder body unwinder)
- (let*-values (((winder db*) (visit winder db env 'value))
- ((db**) db*)
- ((unwinder db*) (visit unwinder db env 'value))
- ((db**) (concat db* db**))
- ((body db*) (visit body (concat db** db) env ctx))
- ((db**) (concat db* db**)))
- (return (make-dynwind src winder body unwinder)
- db**)))
(($ <dynlet> src fluids vals body)
(let*-values (((fluids db*) (parallel-visit fluids db env 'value))
((vals db**) (parallel-visit vals db env 'value))
@@ -458,15 +449,6 @@
env ctx)))
(return (make-dynlet src fluids vals body)
(concat db*** (concat db** db*)))))
- (($ <dynref> src fluid)
- (let*-values (((fluid db*) (visit fluid db env 'value)))
- (return (make-dynref src fluid)
- db*)))
- (($ <dynset> src fluid exp)
- (let*-values (((fluid db*) (visit fluid db env 'value))
- ((exp db**) (visit exp db env 'value)))
- (return (make-dynset src fluid exp)
- (concat db** db*))))
(($ <toplevel-ref>)
(return exp vlist-null))
(($ <module-ref>)
diff --git a/module/language/tree-il/debug.scm
b/module/language/tree-il/debug.scm
index 6a3b3dc..d5dab80 100644
--- a/module/language/tree-il/debug.scm
+++ b/module/language/tree-il/debug.scm
@@ -216,15 +216,6 @@
(for-each (cut visit <> env) fluids)
(for-each (cut visit <> env) vals)
(visit body env))))
- (($ <dynwind> src winder body unwinder)
- (visit winder env)
- (visit body env)
- (visit unwinder env))
- (($ <dynref> src fluid)
- (visit fluid env))
- (($ <dynset> src fluid exp)
- (visit fluid env)
- (visit exp env))
(($ <conditional> src condition subsequent alternate)
(visit condition env)
(visit subsequent env)
diff --git a/module/language/tree-il/effects.scm
b/module/language/tree-il/effects.scm
index b9b34a1..374ab2c 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -211,25 +211,12 @@ of an expression."
(logior (compute-effects producer)
(compute-effects consumer)
(cause &type-check)))
- (($ <dynwind> _ winder body unwinder)
- (logior (compute-effects winder)
- (compute-effects body)
- (compute-effects unwinder)))
(($ <dynlet> _ fluids vals body)
(logior (accumulate-effects fluids)
(accumulate-effects vals)
(cause &type-check)
(cause &fluid)
(compute-effects body)))
- (($ <dynref> _ fluid)
- (logior (compute-effects fluid)
- (cause &type-check)
- &fluid))
- (($ <dynset> _ fluid exp)
- (logior (compute-effects fluid)
- (compute-effects exp)
- (cause &type-check)
- (cause &fluid)))
(($ <toplevel-ref>)
(logior &toplevel
(cause &type-check)))
@@ -286,6 +273,17 @@ of an expression."
(($ <primcall> _ 'make-prompt-tag (arg))
(logior (compute-effects arg) &allocation))
+ (($ <primcall> _ 'fluid-ref (fluid))
+ (logior (compute-effects fluid)
+ (cause &type-check)
+ &fluid))
+
+ (($ <primcall> _ 'fluid-set! (fluid exp))
+ (logior (compute-effects fluid)
+ (compute-effects exp)
+ (cause &type-check)
+ (cause &fluid)))
+
;; Primitives that are normally effect-free, but which might
;; cause type checks, allocate memory, or access mutable
;; memory. FIXME: expand, to be more precise.
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 27da460..bfd338d 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -104,8 +104,6 @@
(($ <conditional> _ test consequent alternate)
(and (singly-valued-expression? consequent)
(singly-valued-expression? alternate)))
- (($ <dynwind> _ winder body unwinder)
- (singly-valued-expression? body))
(else #f)))
(define (truncate-values x)
@@ -517,12 +515,10 @@ top-level bindings from ENV and return the resulting
expression."
($ <toplevel-ref>)
($ <module-ref>)
($ <primitive-ref>)
- ($ <dynref>)
($ <lexical-set>) ; FIXME: these set! expressions
($ <toplevel-set>) ; could return zero values in
($ <toplevel-define>) ; the future
($ <module-set>) ;
- ($ <dynset>) ;
($ <primcall> src (? singly-valued-primitive?)))
(and (<= nmin 1) (or (not nmax) (>= nmax 1))
(make-call src (make-lambda #f '() consumer) (list exp))))
@@ -543,10 +539,6 @@ top-level bindings from ENV and return the resulting
expression."
(($ <prompt>) #f)
(($ <abort>) #f)
- ;; Bail on dynwinds, as that would cause the consumer to run in
- ;; the wrong dynamic context.
- (($ <dynwind>) #f)
-
;; Propagate to tail positions.
(($ <let> src names gensyms vals body)
(let ((body (loop body)))
@@ -861,7 +853,7 @@ top-level bindings from ENV and return the resulting
expression."
(names ... rest)
(gensyms ... rest-sym)
(vals ... ($ <primcall> _ 'list rest-args))
- ($ <primcall> asrc (or 'apply '@apply)
+ ($ <primcall> asrc 'apply
(proc args ...
($ <lexical-ref> _
(? (cut eq? <> rest))
@@ -1002,18 +994,9 @@ top-level bindings from ENV and return the resulting
expression."
(else #f))))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
- (($ <dynwind> src winder body unwinder)
- (make-dynwind src
- (for-value winder)
- (for-tail body)
- (for-value unwinder)))
(($ <dynlet> src fluids vals body)
(make-dynlet src (map for-value fluids) (map for-value vals)
(for-tail body)))
- (($ <dynref> src fluid)
- (make-dynref src (for-value fluid)))
- (($ <dynset> src fluid exp)
- (make-dynset src (for-value fluid) (for-value exp)))
(($ <toplevel-ref> src (? effect-free-primitive? name))
exp)
(($ <toplevel-ref>)
@@ -1115,7 +1098,7 @@ top-level bindings from ENV and return the resulting
expression."
(simplify-conditional
(make-conditional src c (for-tail subsequent)
(for-tail alternate))))))
- (($ <primcall> src '@call-with-values
+ (($ <primcall> src 'call-with-values
(producer
($ <lambda> _ _
(and consumer
@@ -1169,13 +1152,29 @@ top-level bindings from ENV and return the resulting
expression."
(list w u) 2
(match-lambda
((w u)
- (make-seq src
- (make-call src w '())
- (make-begin0 src
- (make-dynwind src w
- (make-call src thunk '())
- u)
- (make-call src u '()))))))))
+ (make-seq
+ src
+ (make-seq
+ src
+ (make-conditional
+ src
+ ;; fixme: introduce logic to fold thunk?
+ (make-primcall src 'thunk? (list u))
+ (make-call src w '())
+ (make-primcall
+ src 'scm-error
+ (list
+ (make-const #f 'wrong-type-arg)
+ (make-const #f "dynamic-wind")
+ (make-const #f "Wrong type (expecting thunk): ~S")
+ (make-primcall #f 'list (list u))
+ (make-primcall #f 'list (list u)))))
+ (make-primcall src 'wind (list w u)))
+ (make-begin0 src
+ (make-call src thunk '())
+ (make-seq src
+ (make-primcall src 'unwind '())
+ (make-call src u '())))))))))
(($ <primcall> src 'values exps)
(cond
@@ -1192,7 +1191,7 @@ top-level bindings from ENV and return the resulting
expression."
(for-tail (list->seq src (append (cdr vals) (list (car vals)))))
(make-primcall src 'values vals))))))
- (($ <primcall> src (or 'apply '@apply) (proc args ... tail))
+ (($ <primcall> src 'apply (proc args ... tail))
(let lp ((tail* (find-definition tail 1)) (speculative? #t))
(define (copyable? x)
;; Inlining a result from find-definition effectively copies it,
@@ -1205,7 +1204,7 @@ top-level bindings from ENV and return the resulting
expression."
(for-tail (make-call src proc (append args args*)))))
(($ <primcall> _ 'cons
((and head (? copyable?)) (and tail (? copyable?))))
- (for-tail (make-primcall src '@apply
+ (for-tail (make-primcall src 'apply
(cons proc
(append args (list head tail))))))
(($ <primcall> _ 'list
@@ -1215,7 +1214,7 @@ top-level bindings from ENV and return the resulting
expression."
(if speculative?
(lp (for-value tail) #f)
(let ((args (append (map for-value args) (list tail*))))
- (make-primcall src '@apply
+ (make-primcall src 'apply
(cons (for-value proc) args))))))))
(($ <primcall> src (? constructor-primitive? name) args)
@@ -1244,6 +1243,15 @@ top-level bindings from ENV and return the resulting
expression."
((name . args)
(make-primcall src name args))))))
+ (($ <primcall> src 'thunk? (proc))
+ (match (for-value proc)
+ (($ <lambda> _ _ ($ <lambda-case> _ req))
+ (for-tail (make-const src (null? req))))
+ (proc
+ (case ctx
+ ((effect) (make-void src))
+ (else (make-primcall src 'thunk? (list proc)))))))
+
(($ <primcall> src (? accessor-primitive? name) args)
(match (cons name (map for-value args))
;; FIXME: these for-tail recursions could take place outside
@@ -1461,7 +1469,7 @@ top-level bindings from ENV and return the resulting
expression."
(define (lift-applied-lambda body gensyms)
(and (not opt) rest (not kw)
(match body
- (($ <primcall> _ '@apply
+ (($ <primcall> _ 'apply
(($ <lambda> _ _ (and lcase ($ <lambda-case>)))
($ <lexical-ref> _ _ sym)
...))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 4a1b98d..cd95084 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -36,12 +36,11 @@
;; When adding to this, be sure to update *multiply-valued-primitives*
;; if appropriate.
(define *interesting-primitive-names*
- '(apply @apply
- call-with-values @call-with-values
- call-with-current-continuation @call-with-current-continuation
+ '(apply
+ call-with-values
+ call-with-current-continuation
call/cc
dynamic-wind
- @dynamic-wind
values
eq? eqv? equal?
memq memv
@@ -51,6 +50,8 @@
not
pair? null? list? symbol? vector? string? struct? number? char? nil?
+ procedure? thunk?
+
complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
char<? char<=? char>=? char>?
@@ -77,7 +78,8 @@
fluid-ref fluid-set!
- @prompt call-with-prompt @abort abort-to-prompt
+ call-with-prompt
+ abort-to-prompt* abort-to-prompt
make-prompt-tag
throw error scm-error
@@ -175,18 +177,19 @@
eq? eqv? equal?
not
pair? null? list? symbol? vector? struct? string? number? char?
+ procedure? thunk?
acons cons cons* list vector))
;; Primitives that don't always return one value.
(define *multiply-valued-primitives*
- '(apply @apply
- call-with-values @call-with-values
- call-with-current-continuation @call-with-current-continuation
+ '(apply
+ call-with-values
+ call-with-current-continuation
call/cc
dynamic-wind
- @dynamic-wind
values
- @prompt call-with-prompt @abort abort-to-prompt))
+ call-with-prompt
+ @abort abort-to-prompt))
;; Procedures that cause a nonlocal, non-resumable abort.
(define *bailout-primitives*
@@ -446,17 +449,8 @@
(define-primitive-expander acons (x y z)
(cons (cons x y) z))
-(define-primitive-expander apply (f a0 . args)
- (@apply f a0 . args))
-
-(define-primitive-expander call-with-values (producer consumer)
- (@call-with-values producer consumer))
-
-(define-primitive-expander call-with-current-continuation (proc)
- (@call-with-current-continuation proc))
-
(define-primitive-expander call/cc (proc)
- (@call-with-current-continuation proc))
+ (call-with-current-continuation proc))
(define-primitive-expander make-struct (vtable tail-size . args)
(if (and (const? tail-size)
@@ -541,67 +535,6 @@
(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
(hashq-set! *primitive-expand-table*
- '@dynamic-wind
- (case-lambda
- ((src pre expr post)
- (let* ((PRE (gensym "pre-"))
- (POST (gensym "post-"))
- (winder (make-lexical-ref #f 'winder PRE))
- (unwinder (make-lexical-ref #f 'unwinder POST)))
- (define (make-begin0 src first second)
- (make-let-values
- src
- first
- (let ((vals (gensym "vals ")))
- (make-lambda-case
- #f
- '() #f 'vals #f '() (list vals)
- (make-seq
- src
- second
- (make-primcall #f 'apply
- (list
- (make-primitive-ref #f 'values)
- (make-lexical-ref #f 'vals vals))))
- #f))))
- (make-let src '(pre post) (list PRE POST) (list pre post)
- (make-seq src
- (make-call src winder '())
- (make-begin0
- src
- (make-dynwind src winder expr unwinder)
- (make-call src unwinder '()))))))))
-
-(hashq-set! *primitive-expand-table*
- 'fluid-ref
- (case-lambda
- ((src fluid) (make-dynref src fluid))
- (else #f)))
-
-(hashq-set! *primitive-expand-table*
- 'fluid-set!
- (case-lambda
- ((src fluid exp) (make-dynset src fluid exp))
- (else #f)))
-
-(hashq-set! *primitive-expand-table*
- '@prompt
- (case-lambda
- ((src tag exp handler)
- (let ((args-sym (gensym)))
- (make-prompt
- src tag exp
- ;; If handler itself is a lambda, the inliner can do some
- ;; trickery here.
- (make-lambda-case
- (tree-il-src handler) '() #f 'args #f '() (list args-sym)
- (make-primcall #f 'apply
- (list handler
- (make-lexical-ref #f 'args args-sym)))
- #f))))
- (else #f)))
-
-(hashq-set! *primitive-expand-table*
'call-with-prompt
(case-lambda
((src tag thunk handler)
@@ -623,7 +556,7 @@
(else #f)))
(hashq-set! *primitive-expand-table*
- '@abort
+ 'abort-to-prompt*
(case-lambda
((src tag tail-args)
(make-abort src tag '() tail-args))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 7322d61..b8d7533 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -874,7 +874,7 @@
(let (args) (_) ((primcall list (const 2) (const 3)))
(seq
(call (toplevel foo!) (lexical args _))
- (primcall @apply
+ (primcall apply
(lambda ()
(lambda-case
(((x y z w) #f #f #f () (_ _ _ _))
@@ -898,7 +898,7 @@
bv
(+ offset 4))))
(let ((args (list x y)))
- (@apply
+ (apply
(lambda (bv offset x y)
(bytevector-ieee-single-native-set!
bv
@@ -938,7 +938,7 @@
;; Here we ensure that non-constant expressions are not copied.
(lambda ()
(let ((args (list (foo!))))
- (@apply
+ (apply
(lambda (z x)
(list z x))
;; This toplevel ref might raise an unbound variable exception.
@@ -959,7 +959,7 @@
(lambda ()
(let ((args (list 'foo)))
(set-car! args 'bar)
- (@apply
+ (apply
(lambda (z x)
(list z x))
z
@@ -971,7 +971,7 @@
((primcall list (const foo)))
(seq
(primcall set-car! (lexical args _) (const bar))
- (primcall @apply
+ (primcall apply
(lambda . _)
(toplevel z)
(lexical args _))))))))
@@ -1070,43 +1070,49 @@
;; the dynwind; alack.
(dynamic-wind foo (lambda () bar) baz)
(let (tmp tmp) (_ _) ((toplevel foo) (toplevel baz))
- (seq (call (lexical tmp _))
- (let (tmp) (_) ((dynwind (lexical tmp _)
- (toplevel bar)
- (lexical tmp _)))
- (seq (call (lexical tmp _))
+ (seq (seq (if (primcall thunk? (lexical tmp _))
+ (call (lexical tmp _))
+ (primcall scm-error . _))
+ (primcall wind (lexical tmp _) (lexical tmp _)))
+ (let (tmp) (_) ((toplevel bar))
+ (seq (seq (primcall unwind)
+ (call (lexical tmp _)))
(lexical tmp _))))))
(pass-if-peval
- ;; Constant guards don't need lexical bindings.
+ ;; Constant guards don't need lexical bindings or thunk? checks.
(dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
- (seq (toplevel foo)
- (let (tmp) (_) ((dynwind (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel foo))))
- (toplevel bar)
- (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel baz))))))
- (seq (toplevel baz)
+ (seq (seq (toplevel foo)
+ (primcall wind
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel foo))))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel baz))))))
+ (let (tmp) (_) ((toplevel bar))
+ (seq (seq (primcall unwind)
+ (toplevel baz))
(lexical tmp _)))))
(pass-if-peval
;; Dynwind bodies that return an unknown number of values need a
;; let-values.
(dynamic-wind (lambda () foo) (lambda () (bar)) (lambda () baz))
- (seq (toplevel foo)
- (let-values (dynwind (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel foo))))
- (call (toplevel bar))
- (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel baz)))))
+ (seq (seq (toplevel foo)
+ (primcall wind
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel foo))))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel baz))))))
+ (let-values (call (toplevel bar))
(lambda-case
((() #f vals #f () (_))
- (seq (toplevel baz)
- (primcall @apply (primitive values) (lexical vals _))))))))
+ (seq (seq (primcall unwind)
+ (toplevel baz))
+ (primcall apply (primitive values) (lexical vals _))))))))
(pass-if-peval
;; Prompt is removed if tag is unreferenced
@@ -1145,7 +1151,7 @@
(const 1)
(lambda-case
((() #f args #f () (_))
- (primcall @apply
+ (primcall apply
(lexical handler _)
(lexical args _)))))))
diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test
index 9407791..eee54e6 100644
--- a/test-suite/tests/procprop.test
+++ b/test-suite/tests/procprop.test
@@ -1,7 +1,7 @@
;;;; procprop.test --- Procedure properties -*- mode: scheme; coding: utf-8;
-*-
;;;; Ludovic Courtès <address@hidden>
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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
@@ -49,7 +49,7 @@
(pass-if "apply"
(equal? (procedure-minimum-arity apply)
- '(1 0 #t)))
+ '(2 0 #t)))
(pass-if "cons*"
(equal? (procedure-minimum-arity cons*)
diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test
index 679e173..56c898c 100644
--- a/test-suite/tests/strings.test
+++ b/test-suite/tests/strings.test
@@ -2,7 +2,7 @@
;;;; Jim Blandy <address@hidden> --- August 1999
;;;;
;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008, 2009, 2010,
-;;;; 2011 Free Software Foundation, Inc.
+;;;; 2011, 2013 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
@@ -546,10 +546,10 @@
(with-test-prefix "string"
(pass-if-exception "convert circular list to string"
- exception:wrong-type-arg
- (let ((foo (list #\a #\b #\c)))
- (set-cdr! (cddr foo) (cdr foo))
- (apply string foo))))
+ '(wrong-type-arg . "Apply to non-list")
+ (let ((foo (list #\a #\b #\c)))
+ (set-cdr! (cddr foo) (cdr foo))
+ (apply string foo))))
(with-test-prefix "string-split"
diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test
index ee64467..15c811c 100644
--- a/test-suite/tests/syncase.test
+++ b/test-suite/tests/syncase.test
@@ -22,6 +22,7 @@
(define-module (test-suite test-syncase)
#:use-module (test-suite lib)
#:use-module (system base compile)
+ #:use-module (ice-9 regex)
#:use-module ((srfi srfi-1) :select (member)))
(define-syntax plus
@@ -274,3 +275,35 @@
(pass-if "syntax-parameters (unresolved)"
(equal? (syntax-type foo #f) 'syntax-parameter)))
+
+;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
+(define-syntax pass-if-syntax-error
+ (syntax-rules ()
+ ((_ name pat exp)
+ (pass-if name
+ (catch 'syntax-error
+ (lambda () exp (error "expected syntax-error exception"))
+ (lambda (k who what where form . maybe-subform)
+ (if (if (pair? pat)
+ (and (eq? who (car pat))
+ (string-match (cdr pat) what))
+ (string-match pat what))
+ #t
+ (error "unexpected syntax-error exception" what pat))))))))
+
+(with-test-prefix "primitives"
+ (pass-if-syntax-error "primref in default module"
+ "failed to match"
+ (macroexpand '(@@ primitive cons)))
+
+ (pass-if-syntax-error "primcall in default module"
+ "failed to match"
+ (macroexpand '((@@ primitive cons) 1 2)))
+
+ (pass-if-equal "primcall in (guile)"
+ '(1 . 2)
+ (@@ @@ (guile) ((@@ primitive cons) 1 2)))
+
+ (pass-if-syntax-error "primref in (guile)"
+ "not in operator position"
+ (macroexpand '(@@ @@ (guile) (@@ primitive cons)))))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 50847fd..edcbdc9 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -653,10 +653,10 @@
(with-test-prefix "apply"
(assert-tree-il->glil
- (primcall @apply (toplevel foo) (toplevel bar))
+ (primcall apply (toplevel foo) (toplevel bar))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref
bar) (call tail-apply 2)))
(assert-tree-il->glil
- (begin (primcall @apply (toplevel foo) (toplevel bar)) (void))
+ (begin (primcall apply (toplevel foo) (toplevel bar)) (void))
(program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref apply) (toplevel ref foo)
(toplevel ref bar) (mv-call 2 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
@@ -664,7 +664,7 @@
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
- (call (toplevel foo) (call (toplevel @apply) (toplevel bar) (toplevel baz)))
+ (call (toplevel foo) (call (toplevel apply) (toplevel bar) (toplevel baz)))
(program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call
apply 2)
@@ -672,10 +672,10 @@
(with-test-prefix "call/cc"
(assert-tree-il->glil
- (primcall @call-with-current-continuation (toplevel foo))
+ (primcall call-with-current-continuation (toplevel foo))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call
tail-call/cc 1)))
(assert-tree-il->glil
- (begin (primcall @call-with-current-continuation (toplevel foo)) (void))
+ (begin (primcall call-with-current-continuation (toplevel foo)) (void))
(program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref call-with-current-continuation)
(toplevel ref foo) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
@@ -684,7 +684,7 @@
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(call (toplevel foo)
- (call (toplevel @call-with-current-continuation) (toplevel bar)))
+ (call (toplevel call-with-current-continuation) (toplevel bar)))
(program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(toplevel ref bar) (call call/cc 1)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-55-g5e0253f,
Andy Wingo <=