-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
-SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
- (SCM in_guard, SCM thunk, SCM out_guard),
- "All three arguments must be 0-argument procedures.\n"
- "@var{in_guard} is called, then @var{thunk}, then\n"
- "@var{out_guard}.\n"
- "\n"
- "If, any time during the execution of @var{thunk}, the\n"
- "continuation of the @code{dynamic_wind} expression is escaped\n"
- "non-locally, @var{out_guard} is called. If the continuation of\n"
- "the dynamic-wind is re-entered, @var{in_guard} is called. Thus\n"
- "@var{in_guard} and @var{out_guard} may be called any number of\n"
- "times.\n"
- "@lisp\n"
- "(define x 'normal-binding)\n"
- "@result{} x\n"
- "(define a-cont (call-with-current-continuation\n"
- " (lambda (escape)\n"
- " (let ((old-x x))\n"
- " (dynamic-wind\n"
- " ;; in-guard:\n"
- " ;;\n"
- " (lambda () (set! x 'special-binding))\n"
- "\n"
- " ;; thunk\n"
- " ;;\n"
- " (lambda () (display x) (newline)\n"
- " (call-with-current-continuation escape)\n"
- " (display x) (newline)\n"
- " x)\n"
- "\n"
- " ;; out-guard:\n"
- " ;;\n"
- " (lambda () (set! x old-x)))))))\n"
- "\n"
- ";; Prints:\n"
- "special-binding\n"
- ";; Evaluates to:\n"
- "@result{} a-cont\n"
- "x\n"
- "@result{} normal-binding\n"
- "(a-cont #f)\n"
- ";; Prints:\n"
- "special-binding\n"
- ";; Evaluates to:\n"
- "@result{} a-cont ;; the value of the (define a-cont...)\n"
- "x\n"
- "@result{} normal-binding\n"
- "a-cont\n"
- "@result{} special-binding\n"
- "@end lisp")
-#define FUNC_NAME s_scm_dynamic_wind
+SCM
+scm_dynamic_wind (SCM in_guard, SCM thunk, SCM out_guard)
+#define FUNC_NAME "dynamic-wind"
{
SCM ans, old_winds;
SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)),
scm_define (CAR (mx), eval (CDR (mx), env));
return SCM_UNSPECIFIED;
+ case SCM_M_DYNWIND:
+ {
+ SCM in, out, res, old_winds;
+ in = eval (CAR (mx), env);
+ out = eval (CDDR (mx), env);
+ scm_call_0 (in);
+ old_winds = scm_i_dynwinds ();
+ scm_i_set_dynwinds (scm_acons (in, out, old_winds));
+ res = eval (CADR (mx), env);
+ scm_i_set_dynwinds (old_winds);
+ scm_call_0 (out);
+ return res;
+ }
+
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
proc = eval (CAR (mx), env);
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_APPLY(exp) \
MAKMEMO (SCM_M_APPLY, exp)
#define MAKMEMO_CONT(proc) \
"let",
"quote",
"define",
+ "dynwind",
"apply",
"call/cc",
"call-with-values",
static SCM scm_m_at_call_with_values (SCM xorig, SCM env);
static SCM scm_m_cond (SCM xorig, SCM env);
static SCM scm_m_define (SCM x, SCM env);
+static SCM scm_m_at_dynamic_wind (SCM xorig, SCM env);
static SCM scm_m_eval_when (SCM xorig, SCM env);
static SCM scm_m_if (SCM xorig, SCM env);
static SCM scm_m_lambda (SCM xorig, SCM env);
SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_m_at_call_with_values);
SCM_SYNTAX (s_cond, "cond", scm_m_cond);
SCM_SYNTAX (s_define, "define", scm_m_define);
+SCM_SYNTAX (s_at_dynamic_wind, "@dynamic-wind", scm_m_at_dynamic_wind);
SCM_SYNTAX (s_eval_when, "eval-when", scm_m_eval_when);
SCM_SYNTAX (s_if, "if", scm_m_if);
SCM_SYNTAX (s_lambda, "lambda", scm_m_lambda);
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_else, "else");
SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
return MAKMEMO_DEFINE (variable, memoize (CAR (body), env));
}
+static SCM
+scm_m_at_dynamic_wind (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 3, s_bad_expression, expr);
+
+ return MAKMEMO_DYNWIND (memoize (CADR (expr), env),
+ memoize (CADDR (expr), env),
+ memoize (CADDDR (expr), env));
+}
+
static SCM
scm_m_eval_when (SCM expr, SCM env)
{
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_IF:
return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
#ifndef SCM_MEMOIZE_H
#define SCM_MEMOIZE_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
SCM_API SCM scm_sym_atcall_cc;
SCM_API SCM scm_sym_at_call_with_values;
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;
SCM_M_LET,
SCM_M_QUOTE,
SCM_M_DEFINE,
+ SCM_M_DYNWIND,
SCM_M_APPLY,
SCM_M_CONT,
SCM_M_CALL_WITH_VALUES,
;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 2009
+;;;; Copyright (C) 2009, 2010
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
(('define (name . x))
(define! name (eval x env)))
+ (('dynwind (in exp . out))
+ (dynamic-wind (eval in env)
+ (lambda () (eval exp env))
+ (eval out env)))
+
(('apply (f args))
(apply (eval f env) (eval args env)))
;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
;;;; Jim Blandy <jimb@cyclic.com> --- October 1996
-;;;; Copyright (C) 1996, 1997, 1998, 2000, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1996, 1997, 1998, 2000, 2001, 2006, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
\f
;;;; apply and call-with-current-continuation
-;;; We want these to be tail-recursive, so instead of using primitive
-;;; procedures, we define them as closures in terms of the primitive
-;;; macros @apply and @call-with-current-continuation.
-(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
-(set-procedure-property! apply 'name 'apply)
+;;; The deal with these is that they are the procedural wrappers around the
+;;; primitives of Guile's language. There are about 20 different kinds of
+;;; expression in Guile, and e.g. @apply is one of them. (It has to be that way
+;;; to preserve tail recursion.)
+;;;
+;;; Usually we recognize (apply foo bar) to be an instance of @apply, but in the
+;;; case that apply is passed to apply, or we're bootstrapping, we need a
+;;; trampoline -- and here they are.
+(define (apply fun . args)
+ (@apply fun (apply:nconc2last args)))
(define (call-with-current-continuation proc)
(@call-with-current-continuation proc))
(define (call-with-values producer consumer)
(@call-with-values producer consumer))
+(define (dynamic-wind in thunk out)
+ "All three arguments must be 0-argument procedures.
+@var{in_guard} is called, then @var{thunk}, then
+@var{out_guard}.
+
+If, any time during the execution of @var{thunk}, the
+continuation of the @code{dynamic_wind} expression is escaped
+non-locally, @var{out_guard} is called. If the continuation of
+the dynamic-wind is re-entered, @var{in_guard} is called. Thus
+@var{in_guard} and @var{out_guard} may be called any number of
+times.
+@lisp
+ (define x 'normal-binding)
+@result{} x
+ (define a-cont
+ (call-with-current-continuation
+ (lambda (escape)
+ (let ((old-x x))
+ (dynamic-wind
+ ;; in-guard:
+ ;;
+ (lambda () (set! x 'special-binding))
+
+ ;; thunk
+ ;;
+ (lambda () (display x) (newline)
+ (call-with-current-continuation escape)
+ (display x) (newline)
+ x)
+
+ ;; out-guard:
+ ;;
+ (lambda () (set! x old-x)))))))
+
+;; Prints:
+special-binding
+;; Evaluates to:
+@result{} a-cont
+x
+@result{} normal-binding
+ (a-cont #f)
+;; Prints:
+special-binding
+;; Evaluates to:
+@result{} a-cont ;; the value of the (define a-cont...)
+x
+@result{} normal-binding
+a-cont
+@result{} special-binding
+@end lisp"
+ (@dynamic-wind in (thunk) out))
\f
;;;; Basic Port Code
,(tree-il->scheme (make-lambda #f '() body))))
((<dynamic-wind> body winder unwinder)
- `(dynamic-wind ,(unparse-tree-il winder)
- (lambda () ,(unparse-tree-il body))
- ,(unparse-tree-il unwinder)))
+ `(dynamic-wind ,(tree-il->scheme winder)
+ (lambda () ,(tree-il->scheme body))
+ ,(tree-il->scheme unwinder)))
((<prompt> tag body handler pre-unwind-handler)
`((@ (ice-9 control) prompt)
call-with-current-continuation @call-with-current-continuation
call/cc
dynamic-wind
+ @dynamic-wind
values
eq? eqv? equal?
memq memv
(make-lexical-ref #f 'post POST)))))))
(else #f)))
+(hashq-set! *primitive-expand-table*
+ '@dynamic-wind
+ (case-lambda
+ ((src pre expr post)
+ (let ((PRE (gensym " pre"))
+ (POST (gensym " post")))
+ (make-let
+ src
+ '(pre post)
+ (list PRE POST)
+ (list pre post)
+ (make-dynamic-wind
+ src
+ (make-lexical-ref #f 'pre PRE)
+ expr
+ (make-lexical-ref #f 'post POST)))))))
+
(hashq-set! *primitive-expand-table*
'prompt
(case-lambda
HCoop / bpt / guile.git / commitdiff